SWAGOLX.EXE (c) 1993 GDSOFT ALL RIGHTS RESERVED 00044 GRAPHICS ROUTINES 1 05-28-9313:47ALL SWAG SUPPORT TEAM DOTSPIN.PAS IMPORT 22 program dotspin;ππvar inPort1:word;πprocedure waitRetrace;assembler;asmπ mov dx,inPort1; {find crt status reg (input port #1)}π@L1: in al,dx; test al,8; jnz @L1; {wait for no v retrace}π@L2: in al,dx; test al,8; jz @L2; {wait for v retrace}π end;ππconstπ tableWriteIndex=$3C8;π tableDataRegister=$3C9;ππprocedure setColor(color,r,g,b:byte);assembler;asm {set DAC color}π mov dx,tableWriteIndex; mov al,color; out dx,al; inc dx;π mov al,r; out dx,al; mov al,g; out dx,al; mov al,b;out dx,al;π end; {write index now points to next color}ππ{plot a pixel in mode $13}πprocedure plot(x,y:word);Inline(π $5E/ { pop si ;y}π $5F/ { pop di ;x}π $B8/$00/$A0/ { mov ax,$A000}π $8E/$C0/ { mov es,ax}π $B8/$40/$01/ { mov ax,320}π $F7/$E6/ { mul si}π $01/$C7/ { add di,ax}π $26/$F6/$15); {es: not byte[di]}ππprocedure plot4(x,y:word);const f=60;beginπ plot(x+f,y);π plot(199+f-x,199-y);π plot(199+f-y,x);π plot(y+f,199-x);π end;ππprocedure click;assembler;asmπ in al,$61; xor al,2; out $61,al;π end;ππconst nDots=21;ππvarπ dot:array[0..nDots-1]of recordπ x,y,sx,sy:integer;π end;ππfunction colorFn(x:integer):byte;beginπ colorFn:=63-(abs(100-x)div 2);π end;ππprocedure moveDots;var i:word;beginπ for i:=0 to nDots-1 do with dot[i] do beginπ plot4(x,y);π inc(x,sx);inc(y,sy);π if(word(x)>200)then beginπ sx:=-sx;inc(x,sx);click;π end;π if(word(y)>199)then beginπ sy:=-sy;inc(y,sy);click;π end;π plot4(x,y);π end;π waitRetrace;waitRetrace;waitRetrace;{waitRetrace;}π setcolor(255,colorFn(dot[0].x),colorFn(dot[3].x),colorFn(dot[6].x));π end;ππprocedure drawdots;var i:word;beginπ for i:=0 to nDots-1 do with dot[i] do plot4(x,y);π end;ππprocedure initDots;var i,j,k:word;beginπ j:=1;k:=1;π for i:=0 to nDots-1 do with dot[i] do beginπ x:=100;y:=99;π sx:=j;sy:=k;π inc(j);if j>=k then begin j:=1;inc(k); end;π end;π end;ππfunction readKey:char;Inline(π $B4/$07/ {mov ah,7}π $CD/$21); {int $21}ππfunction keyPressed:boolean;Inline(π $B4/$0B/ {mov ah,$B}π $CD/$21/ {int $21}π $24/$FE); {and al,$FE}ππbeginπ inPort1:=memw[$40:$63]+6;π port[$61]:=port[$61]and (not 1);π setcolor(255,60,60,63);π initDots;π asm mov ax,$13; int $10; end;π drawDots;π repeat moveDots until keypressed;π readkey;π drawDots;π asm mov ax,3; int $10; end;π end.πππ * OLX 2.2 * Printers do it without wrinkling the sheets.ππ--- Maximus 2.01wbπ * Origin: >>> Sun Mountain BBS <<< (303)-665-6922 (1:104/123)π 2 05-28-9313:47ALL SWAG SUPPORT TEAM MCGATUT.TXT IMPORT 40 MCGA Graphics Tutorialπ Lesson #1π by Jim CookππI'm not sure how this online tutorial will be received, but with yourπcomments and feedback I plan on creating a full-blown animation package. Thisπgraphics library will be available to the public domain and will contain theπfollowing abilities:ππ Setting/Reading Pixelsπ Drawing linesπ Saving/Restoring areas of the screenπ Displaying PCX/LBM files to the screenπ Spriting (Display picture with transparent areas)π Palette control (Smooth fades to black)π Page flippingππBefore we're done, you will have the tools to produce programs with rich,πeven photo-realistic (for the resolution) images on your PC. The necessaryπhardware is a VGA card and monitor that's it. I'll be using Turbo Pascalπversion 6.0. Please holler if that will be a problem. I'm using it toπcreate inline assembly. My alternatives are inline code (yuk) or linking inπexternal assembly. For speed (and actually ease) the latter is better. If Iπreceive three complaints against 6.0, I'll use external assembly.ππ What is MCGA?ππMulti-Color Graphics Array is the video card that IBM built into it's Modelπ25 and 30 PS/2's. It subsequently became a subset of the standard VGAπadapter card. It has the distiction of being the first card (excludingπTarga and other expensive cards) to display 256 colors at once on theπcomputer screen. To us that meant cool games and neat pictures. The MCGAπaddapter has added two new video modes to the PC world:ππ Mode $11 640x480x2 colorsπ Mode $13 320x200x256 colorsππObviously, we will deal with mode $13. If we wanted to deal with twoπcolors, we'd be programming a CGA. So much for the history lesson...let'sπdive in.ππI've created a unit, MCGALib, that will contain all of our MCGA routines.πThe first two procedures we will concern ourselves with are setting theπgraphics mode and setting a pixel. The MCGALib is followed by a testπprogram that uses the two procedures:ππUnit MCGALib;ππinterfaceππProcedure SetGraphMode (Num:Byte);πProcedure SetPixel (X,Y:Integer;Color:Byte);ππimplementationππvarπ ScreenWide : Integer;π ScreenAddr : Word;ππProcedure SetGraphMode (Num:Byte);πbeginπ asmπ mov al,Numπ mov ah,0π int 10hπ end;π Case Num ofπ $13 : ScreenWide := 320;π end;π ScreenAddr := $A000;πend;π{πFunction PixelAddr (X,Y:Word) : Word;πbeginπ PixelAddr := Y * ScreenWide + X;πend;ππProcedure SetPixel (X,Y:Integer;Color:Byte);πvarπ Ofs : Word;πbeginπ Ofs := PixelAddr (X,Y);π Mem [ScreenAddr:Ofs] := Color;πend;π}ππProcedure SetPixel (X,Y:Integer;Color:Byte);πbeginπ asmπ push dsπ mov ax,ScreenAddrπ mov ds,axππ mov ax,Yπ mov bx,320π mul bxπ mov bx,Xπ add bx,axππ mov al,Colorπ mov byte ptr ds:[bx],alπ pop dsπ end;πend;ππBeginπEnd.ππThis is the test program to make sure it's working...ππProgram MCGATest;ππusesπ Crt,Dos,MCGALib;ππvarπ Stop,π Start : LongInt;π Regs : Registers;ππFunction Tick : LongInt;πbeginπ Regs.ah := 0;π Intr ($1A,regs);π= egs.cx hl 16 Rgs.dx;πend;ππProcedure Control;πvarπ I,J : Integr;beginπ Start := ic;π Fr I := 0 to 199 doπ For J SetPixe (J,I,Random(256));π Stop := Tick;πend;ππPocdure Closing;πvarπ Ch : Chr;πbeginπ Repet Until Keypressed;π While Keypressed do Ch:= Reake;π TextMode (3);πook '(Stop-Start),' ticks or ,(Stop-Start)/182:4:3,'π seconds!');πnd;ππProcedure Init;πbeginπ SetGaphMode ($13);π Randoiz;πend;ππBeginπ Initπ Control;π Cosing;πe where these listings coul get unbearably long in time. I'lπexplore a few ays I can get this information to ya'll without takingup tooπmuch pace. Iwould like you tomake sue this routine works, ust in caseπyou ou graphis card. You may notce two SetPxelπprocedures in the MCGALib, one is commented out. Remove he comments,πcomment up the uncommented SetPixel and run the test program aain. Noticeπthe speed degradation. Linking in raw assembly will eve improve upon theπspeed of the inline assembly.πPlease take the time to study each procedure and ASK ANY QUESTIONS tht youπmay have, even if it doesn't relate to the graphics routines. I'm cetain Iπdo not want to get pulled off track by any discussions about STYLE,ur critiqueπ for others to learn rom.ππ Coming next timeππI think a discussio of video memory is paramount. Possibly vertical andπhorizontal lines, if spce permits.ππHappy grafxπjimππ--- QuickBBS 2.75π * Origin: Quantum Leap.. (512)333-5360 HST/DS (1:387/307)π 3 07-16-9306:46ALL SWAG SUPPORT TEAM Simulate Star Field IMPORT 28 ╓ π{Program to simulate travel through a star field - try a different MaxStar}πusesπ TpCrt, TpInline, Graph; {OpInline used for HiWord only}πconstπ MaxStar = 50; {num stars}π MaxHistory = 3; {points per streak, = 2**n -1, note mask on line #59}πtypeπ T_HistoryPoint = recordπ hX, hY : Integer;π end;π T_Star = recordπ X, Y : LongInt; {star position}π DX, DY : LongInt; {delta}π DXPositive,π DYPositive : Boolean;π Speed : Word;π History : array[0..MaxHistory] of T_HistoryPoint; {Position history}π HistIndex : Byte;π end;π T_StarArray = array[1..MaxStar] of T_Star;πvarπ Gd,π Gm,π i,π j : Integer;ππ Color : Word;ππ A : T_StarArray;π BoundX,π BoundY,π CenterX,ππ CenterY : LongInt;ππ Angle : Real;ππ Shift : Byte;ππBEGINπ Gd := Detect;π InitGraph(Gd, Gm, '\turbo\tp');π if GraphResult <> grOk thenπ Halt(1);π Color := GetMaxColor;π BoundX := GetMaxX * 65536;π BoundY := GetMaxY * 65536;π CenterX := GetMaxX * 32768;π CenterY := GetMaxY * 32768;π FillChar(A, SizeOf(A), $FF);π Randomize;π {Background}π for i := 1 to 1500 doπ PutPixel(Random(GetMaxX), Random(GetMaxY), Color);π {Stars}π repeatπ for i := 1 to MaxStar doπ with A[i] doπ beginπ if (X < 0) or (X > BoundX) or (Y < 0) or (Y > BoundY) thenπ beginπ {Position is off-screen, go back to center, new angle}π Angle := 6.283185 * Random;π Speed := Random(2000) + 1000;π DX := Round(Speed * Sin(Angle));π DY := Round(Speed * Cos(Angle));π X := 300 * DX + CenterX;π Y := 300 * DY + CenterY;π DXPositive := DX > 0;π DYPositive := DY > 0;π DX := Abs(DX);π DY := Abs(DY);π {Erase all of old line segment}π for j := 0 to MaxHistory doπ with History[j] doπ PutPixel(hX, hY, 0);π endπ elseπ begin {Plot point}π Inc(HistIndex); {Next slot in history}π HistIndex := HistIndex and $03; { <-- change for new MaxHistory!}π with History[HistIndex] doπ beginπ PutPixel(hX, hY, 0); {Erase inner dot of line segment}π hX := HiWord(X);π hY := HiWord(Y);π PutPixel(hX, hY, Color); {New outer dot of line segment}π end;π {Next point}π if DXPositive thenπ Inc(X, DX)π elseπ Dec(X, DX); {Add delta}π if DYPositive thenπ Inc(Y, DY)π elseπ Dec(Y, DY);π case Speed ofπ 1000..1300 : Shift := 9;π 1300..1600 : Shift := 8;π 1600..2100 : Shift := 7;π 2100..2700 : Shift := 6;π 2700..2900 : Shift := 5;π 2900..3000 : Shift := 4;π end;π Inc(DX, DX shr Shift); {Increase delta to accelerate}π Inc(DY, DY shr Shift);π end;π end;π until KeyPressed;π ReadLn;π CloseGraph;πEND.ππ 4 07-16-9306:47ALL SWAG SUPPORT TEAM A simple Star Field IMPORT 11 ╓ πprogram stars;ππconstπ maxstars = 200;ππvar star : array[0..maxstars] of word;π speed : array[0..maxstars] of byte;π i : word;ππprocedure create;πbeginπ for i := 0 to maxstars doπ beginπ star[i] := random(320) + random(200) * 320;π speed[i] := random(3) + 1;π if mem[$a000:star[i]] = 0 thenπ mem[$a000:star[i]] := 100;π end;πend;ππProcedure moveit; assembler;πasmπ xor bp,bpπ mov ax,0a000hπ mov es,axπ lea bx,starπ lea si,speedπ mov cx,320ππ@l1: mov di,[bx]π mov al,es:[di]π cmp al,100π jne @j1π xor al,alπ stosbπ@j1: mov al,[si]π xor ah,ahπ add [bx],axπ mov ax,bxπ xor dx,dxπ div cxπ mul cxπ mov dx,bxπ sub dx,axπ cmp dx,319π jle @j3π sub [bx],cxπ@j3: mov di,[bx]π mov al,es:[di]π or al,alπ jnz @j2π mov al,100π stosbπ@j2: add bx,2π inc siπ inc bpπ cmp bp,maxstarsπ jle @l1πend;ππbeginπ asmπ mov ax,13hπ int 10hπ call createπ@l1:π mov dx,3dahπ@r1:π in al,dxπ test al,8π je @r1π call moveitπ in al,60hπ cmp al,1π jne @l1;π end;πend.ππ 5 07-16-9306:47ALL SWAG SUPPORT TEAM A Color Star Field IMPORT 29 ╓ {-------------------------- SCHNIPP -----------------------------}ππ{STARSCROLL.PAS geaenderte Fassung }ππ{$A+,B-,D-,E-,F+,I+,L-,N-,O-,R-,S-,V-}π{$M 64000,0,655360}ππUSES crt,graph,BGIDriv; {ich binde die Treiber ein}ππCONST MaxStars=500; {auf meinem 386-25er muss ich inπ der geaenderten Fassung schon 500π Sterne eintragen, damit es nur nochπ ein wenig schneller ist als die alteπ Fassung mit 100 Sternen ;-)}ππTYPE Punkt=ARRAY[1..3] OF INTEGER; {Siehe ganz unten Move()}ππVARπ gd,gm,mpx,mpy,scal,a,b,e:integer;π Stars1,Stars:ARRAY[1..MaxStars] OF Punkt;ππ mx,my,m2x,m2y,sop, {siehe Init}π act:INTEGER;ππPROCEDURE dpunkt( x,y,z, Col:integer);πVAR n:INTEGER;π BEGINπ n:=z+e;ππ {n=Nenner, nur einmal berechnen, geht schneller}ππ PutPixel(mpx+ (scal*x div n),mpy+ (scal*y div n),col);ππ {hier nur integer-operationen}π END;ππPROCEDURE dline( x1,y1,z1,x2,y2,z2:integer);πVAR n1,n2:INTEGER;π BEGINπ n1:=z1+e;n2:=z2+e; {n1=Nenner fuer 1.Punkt, n2=Nenner fuer 2.Punkt}ππ Line(mpx+(scal*(x1 div n1)),mpy+(scal*(y1 div n1)),π mpx+(scal*(x2 div n2)),mpy+(scal*(y2 div n2)));ππ {Nix mit Round(xxx / nX), dauert zu lange: Integer ->Real ->Integer}π END;ππPROCEDURE Init;πbeginπ act:=1;π e:=1;π scal := 2;ππ mx:=getmaxx; {damit man es auch in EgaLo oder anderen GModes}π m2x:=mx shr 1; {betreiben kann, alle Werte abhaengig von MaximalX und}π my:=getmaxy; {MaximalY}π m2y:=my shr 1;π mpx:=m2x;π mpy:=m2y-(mpy shr 1);ππ sop:=sizeof(punkt); {Schreibt sich leichter :-) }πend;ππBEGINπ Randomize;π gd:=ega;π gm:=egahi;ππ if RegisterBGIdriver(@EgaVgaDriverProc) < 0 then halt(255);ππ InitGraph(gd,gm,''); {oder InitGraph(gd,gm,'PathToDriver');}π Init;π FOR a:=0 TO 15 DO SetRGBPalette(a,a*3,a*3,a*3);π FOR a:=1 TO MaxStars DOπ BEGINπ Stars[a,1]:=Random(mx)-m2x;π Stars[a,2]:=Random(my)-m2y;π Stars[a,3]:=Random(30)+1;π END;ππ Move(Stars,Stars1,SoP*MaxStars); {man sollte Stars1 initialisieren}π {wenn man es benutzt}π SetColor(15);π SetVisualPage(act);ππ {AB hier kommt es auf Geschwindigkeit an}ππ REPEATπ {IF act=0 THEN act:=1 ELSE act:=0; dauert zu lange, deshalb:}π {wenn (act)=1 -> act:=1-(1) = 0 wenn (act)=0 -> act:=1-(0)=1}π act:=1-act;ππ SetActivePage(act);π FOR a:= 1 TO MaxStars DOπ BEGINπ Stars[a,3]:=Stars[a,3]-1;π IF stars[a,3]= 0 THENπ BEGINπ Stars[a,1]:=Random(mx)-m2x;π Stars[a,2]:=Random(my)-m2y;π Stars[a,3]:=30;π END;π dpunkt(Stars[a,1],Stars[a,2],Stars[a,3],15-(stars[a,3] shr 1));ππ {round(xxx/2) dauert zu lange {shr 1 = div 2 }π END;π SetVisualPage(act);ππ act:=1-act; {s.o.}ππ SetActivePage(act);π FOR a:=1 TO MaxStars DOπ BEGINπ dpunkt(Stars1[a,1],Stars1[a,2],Stars1[a,3],0);ππ {Wenn man Stars1 nicht initialisierst kommt es schon mal vor, dassπ man einen Division by Zero Error beim ersten beim 1. Aufruf erhaelt}ππ move(stars[a],stars1[a],sop);ππ {nicht einzeln uebertragen, Move ist schneller, deshalb auch Type Punkt}ππ END;ππ act:=1-act; {s.o.}ππ UNTIL KeyPressed;ππ closegraph; {Nicht vergessen !!!! ;-) }πEND.ππ{------------------------- SCHNAPP --------------------------------------}ππ 6 08-23-9309:18ALL SEAN PALMER FAST Mode 13h Line Draw IMPORT 29 ╓ {π===========================================================================π BBS: Beta ConnectionπDate: 08-20-93 (09:59) Number: 2208πFrom: SEAN PALMER Refer#: NONEπ To: ALL Recvd: NO πSubj: FAST mode 13h Li (Part 1) Conf: (232) T_Pascal_Rπ---------------------------------------------------------------------------πHey! Here's THE fastest mode 13h bresenham's line drawing function ever.π(I think...prove me wrong, please!!)ππIt's written for TP 6 or better, uses BASM. If you don't know assembly, justπput it in a unit and don't worry about how it works. If you do, fine.πSome good optimizations in there...ππHave fun! If anyone wants the mostly-pascal equivalent, let me know.πIt's still fast.ππ{by Sean Palmer}π{public domain}ππvar color:byte;ππprocedure line(x,y,x2,y2:word);assembler;asm {mode 13}π mov ax,$A000π mov es,axπ mov bx,xπ mov ax,yπ mov cx,x2π mov si,y2π cmp ax,siπ jbe @NO_SWAP {always draw downwards}π xchg bx,cxπ xchg ax,siπ@NO_SWAP:π sub si,ax {yd (pos)}π sub cx,bx {xd (+/-)}π cld {set up direction flag}π jns @H_ABSπ neg cx {make x positive}π stdπ@H_ABS:π mov di,320π mul diπ mov di,axπ add di,bx {di:adr}π or si,siπ jnz @NOT_Hπ{horizontal line}π cldπ mov al,colorπ inc cxπ rep stosbπ jmp @EXITπ@NOT_H:π or cx,cxπ jnz @NOT_Vπ{vertical line}π cldπ mov al,colorπ mov cx,siπ inc cxπ mov bx,320-1π@VLINE_LOOP:π stosbπ add di,bxπ loop @VLINE_LOOPπ jmp @EXITπ@NOT_V:π cmp cx,si {which is greater distance?}π lahf {then store flags}π ja @H_INDπ xchg cx,si {swap for redundant calcs}π@H_IND:π mov dx,si {inc2 (adjustment when decision var rolls over)}π sub dx,cxπ shl dx,1π shl si,1 {inc1 (step for decision var)}π mov bx,si {decision var, tells when we need to go secondary direction}π sub bx,cxπ inc cxπ push bp {need another register to hold often-used constant}π mov bp,320π mov al,colorπ sahf {restore flags}π jb @DIAG_Vπ{mostly-horizontal diagonal line}π or bx,bx {set flags initially, set at end of loop for other iterations}π@LH:π stosb {plot and move x, doesn't affect flags}π jns @SH {decision var rollover in bx?}π add bx,siπ loop @LH {doesn't affect flags}π jmp @Xπ@SH:π add di,bpπ add bx,dxπ loop @LH {doesn't affect flags}π jmp @Xπ@DIAG_V:π{mostly-vertical diagonal line}π or bx,bx {set flags initially, set at end of loop for other iterations}π@LV:π mov es:[di],al {plot, doesn't affect flags}π jns @SV {decision var rollover in bx?}π add di,bp {update y coord}π add bx,siπ loop @LV {doesn't affect flags}π jmp @Xπ@SV:π scasb {sure this is superfluous but it's a quick way to inc/dec x coord!}π add di,bp {update y coord}π add bx,dxπ loop @LV {doesn't affect flags}π@X:π pop bpπ@EXIT:π end;ππvar k,i,j:word;πbeginπ asm mov ax,$13; int $10; end;π for k:=0 to 31 do beginπ i:=k*10;π j:=k*6;π color:=14;π line(159,99,i,0);π color:=13;π line(160,99,319,j);π color:=12;π line(160,100,319-i,199);π color:=11;π line(159,100,0,199-j);π i:=k*9;π j:=k*5;π color:=6;π line(i,0,159,99);π color:=5;π line(319,j,160,99);π color:=4;π line(319-i,199,160,100);π color:=3;π line(0,199-j,159,100);π end;π Readln;π asm mov ax,3; int $10; end;π end.ππ... I'm not unemployed, I'm indefinitely leisured.π___ Blue Wave/QWK v2.12π---π * deltaComm Online 919-481-9399 - 10 linesπ * PostLink(tm) v1.06 DELTA (#22) : RelayNet(tm) HUBπ 7 08-27-9319:57ALL STEVE CONNET 3D Rotations IMPORT 22 ╓ {πSTEVE CONNETππOkay, here's the equations For 3D rotations...ππx,y,z are the coordinates of the point you want to rotate.πrx,ry,rz are the amount of rotation you want (in degrees) For x,y,zπ}ππ x1 := round(cos(rad(ry)) * x - sin(rad(ry)) * z);π z1 := round(sin(rad(ry)) * x + cos(rad(ry)) * z);π x := round(cos(rad(rz)) * x1 + sin(rad(rz)) * y);π y1 := round(cos(rad(rz)) * y - sin(rad(rz)) * x1);π z := round(cos(rad(rx)) * z1 - sin(rad(rx)) * y1);π y := round(sin(rad(rx)) * z1 + cos(rad(rx)) * y1);ππ{πBecause in Turbo Pascal, COS and SIN require radians For the argument,πI wrote a short Function called RAD() that converts degrees into radiansπ(I find degrees much easier to visualize)π}ππ Function Rad(i : Integer) : Real;π beginπ Rad := i * (Pi / 360);π end;ππ{πOf course, since most computers don't have 3D projection screens <G>,πuse these equations to provide a sense of perspective to the Object,πbut With 2D coordinates you can plot on a screen.ππx,y,z are from the equations above, and xc,yc,zc are the center pointsπfor the Object that you are rotating... I recommend setting xc,yc at 0,0πbut zc should be very high (+100).π}π x2 := trunc((xc * z - x * zc) / (z - zc));π y2 := trunc((yc * z - y * zc) / (z - zc));ππ{πAlternatively, if you don't want to bother With perspective, just dropπthe z values, and just plot the (x,y) instead.πππTo use these equations, pick a 3D Object and figure out what the 3Dπcoordinates are For each point on the Object. You will have to have someπway to let the computer know which two points are connected. For theπcube that I did, I had one Array For the points and one For each faceπof the cube. That way the computer can draw connecting lines For eachπface With a simple for-loop.π}ππTypeπ FaceLoc = Array [1..4] of Integer;π PointLoc = Recordπ x, y, z : Integer;π end;ππConstπ face_c : Array [1..6] of faceloc =(π (1,2,3,4),π (5,6,2,1),π (6,5,8,7),π (4,3,7,8),π (2,6,7,3),π (5,1,4,8));ππ point_c : Array [1..8] of pointloc =(π (-25, 25, 25),π ( 25, 25, 25),π ( 25,-25, 25),π (-25,-25, 25),π (-25, 25,-25),π ( 25, 25,-25),π ( 25,-25,-25),π (-25,-25,-25));π{πThere you go. I'm not going to get much more complicated For now. if youπcan actually get these equations/numbers to work (and I haven't forgottenπanything!) leave me another message, and I'll give you some advice forπfilling in the sides of the Object (so that you can only see 3 sides atπonce) and some advice to speed things up abit. if you have any problemsπwith whats here, show some other people, and maybe as a collective you canπfigure it out. Thats how I got this one started!π}π 8 08-27-9320:02ALL THOMAS GROFF Endpoints of PIE SegmentIMPORT 10 ╓ {πTHOMAS GROFFππ> would like a unit to return the endpoints of a PIE segment. You couldπ> always draw the arc invisibly and then use the GetArcCoords() procedureπ> provided in the graph unit and save yourself some time.π}ππprogram getlegs;πusesπ graph;πvarπ pts3 : arccoordstype; { <---- Necessary to declare this type var. }π rad,π startang,π endang,π x, y,π gd, gm : integer;πbeginπ gd := detect;π InitGraph(gd,gm,'e:\bp\bgi');π cleardevice;π x := 100;π y := 100;π startang := 25;π endang := 130;π rad := 90;ππ setcolor(getbkcolor); { <------ Draw arc in background color. }π arc(x, y, startang, endang, rad);π GetArcCoords(pts3); { <----- This is what you want, look it up! }π setcolor(white); { <----- Show your lines now.}π line(pts3.x, pts3.y, pts3.xstart, pts3.ystart);π line(pts3.x, pts3.y, pts3.xend, pts3.yend);π outtextxy(50, 150, 'Press enter to see your original arc when ready...');ππ readln;π setcolor(yellow);π arc(x, y, startang, endang, rad);π outtextxy(50, 200, 'Press enter stop demo.');π readln;π closegraph;πend.π 9 08-27-9320:03ALL STEPHEN CHEOK ASM Fading IMPORT 11 ╓ {πSTEPHEN CHEOKππ> Could you post the fade out source?π}ππPROCEDURE DimDisplay(delayfactor : INTEGER); ASSEMBLER;ππ{ Total time to fade out in seconds = ((DelayFactor+1)*MaxIntensity) / 1000 }ππCONSTπ MaxIntensity = 45;π {MaxIntensity = 63;}ππVARπ DACTable : Array [0..255] OF RECORDπ R, G, B : BYTE;π END;πASMπ PUSH DSπ MOV AX, SSπ MOV ES, AXπ MOV DS, AXππ { Store colour information into DACTable }ππ LEA DX, DACTableπ MOV CX, 256π XOR BX, BXπ MOV AX, 1017hπ INT 10hππ MOV BX, MaxIntensityππ { VGA port 3C8h: PEL address register, (colour index,π increments automatically after every third write)π VGA port 3C9h: PEL write register (R, G, B) }ππ CLDπ @1:π LEA SI, DACTableπ MOV DI, SIπ MOV CX, 3*256π XOR AX, AXπ MOV DX, 3C8hπ OUT DX, ALπ INC DXππ { Get colour value, decrement it and update the table }ππ @2:π LODSBπ OR AX, AXπ JZ @3π DEC AXπ @3:π STOSBπ OUT DX, ALπ LOOP @2ππ { Delay before next decrement of R, G, B values }ππ PUSH ESπ PUSH BXπ MOV AX, DelayFactorπ PUSH AXπ CALL Delayπ POP BXπ POP ESππ DEC BXπ OR BX, BXπ JNZ @1π POP DSπEND; { DimDisplay }πππ 10 08-27-9320:14ALL RANDY PARKER Including BGI in EXE IMPORT 23 ╓ {πRANDY PARKERππ> Does anyone out there knwo how you can compile a Program using one ofπ> Borland's BGI units for grpahics and not have to distribute the BGIπ> file(s) with the EXE?ππ First, convert the BGI and CHR files to .OBJ files (object) by usingπBINOBJ.EXE. You may just want to clip out the following and name it as a batchπfile.ππ BINOBJ.EXE goth.chr goth gothicfontprocπ BINOBJ.EXE litt.chr litt smallfontprocπ BINOBJ.EXE sans.chr sans sansseriffontprocπ BINOBJ.EXE trip.chr trip triplexfontprocπ BINOBJ.EXE cga.bgi cga cgadriverprocπ BINOBJ.EXE egavga.bgi egavga egavgadriverprocπ BINOBJ.EXE herc.bgi herc hercdriverprocπ BINOBJ.EXE pc3270.bgi pc3270 pc3270driverprocπ BINOBJ.EXE at.bgi att attdriverprocππ You should now have the following files:ππ ATT.OBJ, CGA.OBJ, EGAVGA.OBJ GOTH.OBJ HERC.OBJ LITT.OBJ PC3270.OBJ,π SANS.OBJ, TRIP.OBJ.π}ππunit GrDriver;ππinterfaceππuses Graph;ππimplementationππprocedure ATTDriverProc; External; {$L ATT.OBJ}πprocedure CGADriverProc; External; {$L CGA.OBJ}πprocedure EGAVGADriverProc; External; {$L EGAVGA.OBJ}πprocedure HercDriverProc; External; {$L HERC.OBJ}πprocedure PC3270DriverProc; External; {$L PC3270.OBJ}ππprocedure ReportError(s : string);πbeginπ writeln;π writeln(s, ': ', GraphErrorMsg(GraphResult));π Halt(1);πend;ππbeginπ if RegisterBGIdriver(@ATTDriverProc) < 0 thenπ ReportError('AT&T');π if RegisterBGIdriver(@CGADriverProc) < 0 thenπ ReportError('CGA');π if RegisterBGIdriver(@EGAVGADriverProc) < 0 thenπ ReportError('EGA-VGA');π if RegisterBGIdriver(@HercDriverProc) < 0 thenπ ReportError('Hercules');π if RegisterBGIdriver(@PC3270DriverProc) < 0 thenπ ReportError('PC-3270');πend.πππunit GrFont;ππinterfaceππusesπ Graph;ππimplementationππprocedure GothicFontProc; External; {$L GOTH.OBJ}πprocedure SansSerifFontProc; External; {$L SANS.OBJ}πprocedure SmallFontProc; External; {$L LITT.OBJ}πprocedure TriplexFontProc; External; {$L TRIP.OBJ}ππprocedure ReportError(s : string);πbeginπ writeln;π writeln(s, ' font: ', GraphErrorMsg(GraphResult));π halt(1)πend;ππbeginπ if RegisterBGIfont(@GothicFontProc) < 0 thenπ ReportError('Gothic');π if RegisterBGIfont(@SansSerifFontProc) < 0 thenπ ReportError('SansSerif');π if RegisterBGIfont(@SmallFontProc) < 0 thenπ ReportError('Small');π if RegisterBGIfont(@TriplexFontProc) < 0 thenπ ReportError('Triplex');πend.ππ{πBy using the 2 units above, you should be able to include any video driverπof font (that were listed) by simply insertingππUsesπ GrFont, GrDriver, Graph;ππinto your graphic files.ππI got this out of a book name Mastering Turbo Pascal 6, by Tom Swan. It's anπexcellent book that covers from Turbo 4.0 to 6.0, basics to advanced subjects.πHope it works for you.π}π 11 08-27-9320:16ALL WILBER VAN LEIJEN Very Large Graphic Image IMPORT 15 ╓ {πWILBERT VAN LEIJENππ> I am looking for a way to get an Image into a pointer (besides arrays)π> and write it to my disk. I am using arrays right now, and works fine, butπ> When I get big images I run out of mem fast... :: IBUF : array [1..30000]π> of byte; getimage(x1,y1,x2,y2,IBUF); repeat Write(f,IBUF[NUM]); num:=num+1;π> until num=sizeof(ibuf);π> This works as long as I dont try to grab a large image.ππThese "large images" are in fact stored in "planes", chunks of up to 64 kByteπin size. You must understand the VGA architecture to store these in a file.πThe only VGA video mode that keeps all data (from the programmer's point ofπview) into a single data space is mode 13h (320x200 with 256 colours): a simpleπarray [1..200, 1..320] of Byte. The other video modes require you to accessπthe VGA hardware: take for example 640x480 by 16 colours: 4 planes of 38,400πbytes (Red, Green, Blue and Intensity). Together with the colour informationπas returned by BIOS call INT 10h/AX=1012h they make up the picture.ππHere's how you select a plane:π}ππProcedure SwitchBitplane(plane : Byte); Assembler;ππASMπ MOV DX, 3C4hπ MOV AL, 2π OUT DX, ALπ INC DXπ MOV AL, planeπ OUT DX, ALπend;ππ{πAssume the video mode to be 12h (640x480/16 colours), BitplaneSize = 38400, andπBitplane is an Array[0..3] of pointer to an array [1..38400] of Byte:π}π For i := 0 to 3 Doπ Beginπ SwitchBitplane(1 shl i);π Move(Bitplane[i]^, Ptr($A000, $0000)^, BitplaneSize);π end;π{πThis is a snippet of code lifted from my VGAGRAB package; a TSR that dumpsπgraphic information (any standard VGA mode) to a disk file by pressingπ<PrtScr>, plus a few demo programs written in TP - with source code. Availableπon FTP sites.π}π 12 08-27-9320:18ALL RAPHAEL VANNEY Display Text in Graphics IMPORT 11 ╓ {πRAPHAEL VANNEYππ*You mean displaying Text While in Graphics mode :-) ?ππ> Yup. Already got a suggestion on using 640x480 With 8x8 font, so ifπ> you have any other one please do tell.. ttyl...ππSure. Just call the BIOS routines to display Characters With a "standard"πlook. By standard look, I mean they look like they were Characters inπText mode.ππOkay, here is the basic Procedure to display a String (Works in any Text/πGraphics mode) :π}ππProcedure BIOSWrite(Str : String; Color : Byte); Assembler;πAsmπ les di, Strπ mov cl, es:[di] { cl = longueur chane }π inc di { es:di pointe sur 1er caractre }π xor ch, ch { cx = longueur chane }π mov bl, Color { bl:=coul }π jcxz @ExitBW { sortie si Length(s)=0 }π @BoucleBW:π mov ah, 0eh { sortie TTY }π mov al, es:[di] { al=caractre afficher }π int 10h { et hop }π inc di { caractre suivant }π loop @BoucleBWπ @ExitBW:πend ;ππ{πI'm not sure how to manage the background color in Graphics mode ; maybeπyou should experiment With values in "coul", there could be a magic bitπto keep actual background color.π}ππ 13 08-27-9320:18ALL SEAN PALMER Bit Map scaler IMPORT 18 ╓ {πSEAN PALMERππWell, I got a wild hair up my butt and decided to convert thatπbitmap scaler I posted into an inline assembler procedure (mostly)πIt's now quite a bit faster...ππby Sean Palmerπpublic domainπ}ππ{bitmaps are limited to 256x256 (duh)}ππtypeπ fixed = recordπ case boolean ofπ true : (w : longint);π false : (f, i : word);π end;ππconstπ bmp : array [0..3, 0..3] of byte =π ((0, 1, 2, 3),π (1, 2, 3, 4),π (2, 3, 4, 5),π (3, 4, 5, 6));πvarπ bmp2 : array [0..63, 0..63] of byte;π i, j : integer;ππprocedure scaleBitmap(var bitmap; x, y : byte; x1, y1, x2, y2 : word);πvarπ s, w, h : word; {xSkip,width,height}π sx, sy, cy : fixed; {xinc, yinc, ySrcPos}πbeginπ w := x2 - x1 + 1;π h := y2 - y1 + 1;π sx.w := x * $10000 div w;π sy.w := y * $10000 div h;π s := 320-w;π cy.w := 0;π asmπ push dsπ mov ds, word ptr bitmap+2;π mov ax, $A000π mov es, ax {setup screen seg}π cldπ mov ax, 320π mul y1π add ax, x1π mov di, ax {calc screen adr}π @L2:π mov ax, cy.iπ mul xπ mov bx, axπ add bx, word ptr bitmap {offset}π mov cx, wπ mov si, 0 {fraction of src adr (bx.si)}π mov dx, sx.fπ @L:π mov al, [bx]π stosbπ add si, dxπ adc bx, sx.i {if carry or sx.i<>0, new source pixel}π loop @Lπ add di, s {skip to next screen row}π mov ax, sy.fπ mov bx, sy.iπ add cy.f, axπ adc cy.i, bxπ dec word ptr hπ jnz @L2π pop dsπ end;πend;ππbeginπ for i := 0 to 63 do {init bmp2}π for j := 0 to 63 doπ bmp2[j, i] := j + (i xor $19) + 32;π asmπ mov ax, $13π int $10π end; {init vga mode 13h}π for i := 2 to 99 do {test bmp}π scaleBitMap(bmp, 4, 4, 0, 0, i * 2 - 1, i * 2 - 1);π for i := 99 downto 2 doπ scaleBitMap(bmp, 4, 4, 0, 0, i * 2 - 1, 197);π for i := 1 to 66 do {test bmp2}π scaleBitMap(bmp2, 64, 64, 0, 0, i * 2 - 1, i * 3 - 1);π for i := 66 downto 1 doπ scaleBitMap(bmp2, 64, 64, 0, 0, i * 2 - 1, i * 2 - 1 + 66);π asmπ mov ax, $3π int $10π end; {restore text mode}πend.π 14 08-27-9320:25ALL MICHAEL NICOLAI Drawing Graphic Circles IMPORT 23 ╓ {πMICHAEL NICOLAIπππThe basic formula (and quickest) For drawing a circle is: x^2 + y^2 = r^2.πThe r stands For radius (half the diameter). You know this formula, i amπsure. A guy called Phytagoras set i up very long ago to calculate theπhypotenuse of a given triangle. (there has to be a 90° angel between a and b)πππ |\π | \π a | \ c c^2 = a^2 + b^2π | \π |____\ππ bππRemember?ππNow look at this: ...| a quater of the circleπ .. |π . ____|yπ . |\ |π . | \ |π . | r\ |π . | \|π --------------------------π r x |0π |π |πππr is given and take 0 - r as a starting point For x. Then all you have to doπis to calculate y and plot the point.ππ y = sqrt((r * r) - (x * x)) sqrt : square rootππAfter each calculation x is increased Until it has reached 0. Then oneπquarter of the circle is drawn. The other three quarters are symmetrical.ππI have written a short Program For you to draw a circle in 320x200x256πGraphics mode. When you key in some values please remember that NO errorπchecking will be done. x has to be between 0 and 319, and y between 0 andπ199. The radius must not be greater than x and y.ππExample: x : 160; y : 100; r : 90ππWhen you start this Program you will not get correct circles because inπGraphics mode ONE pixel is not square!!! You have to calculate an aspectπratio to get nice looking circles.π}ππProgram circle;ππUsesπ Crt, Dos;ππVarπ regs : Registers;π x0, y0 : Word;π x, y, R : Real;π temp : Real;π c : Char;ππProcedure putpixel(x, y : Word; color : Byte);πbeginπ mem[$A000: (y * 320 + x)] := color;πend;ππbeginπ ClrScr;π Writeln('Enter coordinates of middle-point :');π Writeln;π Write('x : '); readln(x0);π Write('y : '); readln(y0);π Writeln;π Write('Enter radius :'); readln(R);ππ { Switch to 320x200x256 }ππ regs.ax := $0013;π intr($10, regs);ππ x := (-1) * R; { go from 0 - R to 0 }π temp := R * R;π Repeatπ y := sqrt(temp - (x * x));π putpixel((x0 + trunc(x)), (y0 - trunc(y)), 15); { 4.th quadrant }π putpixel((x0 - trunc(x)), (y0 - trunc(y)), 15); { 1.st quadrant }π putpixel((x0 + trunc(x)), (y0 + trunc(y)), 15); { 3.rd quadrant }π putpixel((x0 - trunc(x)), (y0 + trunc(y)), 15); { 2.nd quadrant }π x := x + 0.1; { change this if you want coarse or fine circle. }π Until (x >= 0.0);π c := ReadKey; { wait For keypress. }ππ { Switch back to Textmode. }ππ regs.ax := $0003;π intr($10, regs);πend.π 15 08-27-9320:25ALL MICHAEL NICOLAI More Graphic Circles IMPORT 25 ╓ {πMICHAEL NICOLAIππ>does someone have a circle routine For the 320x200x256 mode.π>I need one using the Assembler... (FAST) ( or isn't that possible)π>I doesn't need to be very perfect, if it has the shape of a circle,π>I'm satisfied.ππI don't have any Asm-Program yet but i got the same question some time ago.ππOk then, let's do some math:ππThe basic formula (and quickest?) For drawing a circle is: x^2 + y^2 = r^2.πThe r stands For radius (half the diameter). You know this formula, i amπsure. A guy called Phytagoras set i up very long ago to calculate theπhypotenuse of a given triangle.ππ |\π | \π a | \ c c^2 = a^2 + b^2π | \π |____\ππ bπRemember?ππNow look at this: ...| a quater of the circleπ .. |π . ____|yπ . |\ |π . | \ |π . | r\ |π . | \|π --------------------------π r x |0π |π |ππr is given and take 0 - r as a starting point For x. Then all you have to doπis to calculate y and plot the point.ππ y = sqrt((r * r) - (x * x)) sqrt : square rootππAfter each calculation x is increased Until it has reached 0. Then oneπquarter of the circle is drawn. The other three quarters are symmetrical.ππI have written a short Program For you to draw a circle in 320x200x256πGraphics mode. When you key in some values please remember that NO errorπchecking will be done. x has to be between 0 and 319, and y between 0 andπ199. The radius must not be greater than x and y.ππExample: x : 160; y : 100; r : 90ππWhen you start this Program you will not get correct circles because inπGraphics mode ONE pixel is not square!!! You have to calculate an aspectπratio to get nice looking circles.π}ππProgram circle;ππUsesπ Crt, Dos;ππVarπ regs : Registers;π x0, y0 : Word;π x, y, R : Real;π temp : Real;π c : Char;ππProcedure putpixel(x, y : Word; color : Byte);πbeginπ mem[$A000 : (y * 320 + x)] := color;πend;ππbeginπ ClrScr;π Writeln('Enter coordinates of middle-point :');π Writeln;π Write('x : ');π readln(x0);π Write('y : ');π readln(y0);π Writeln;π Write('Enter radius :');π readln(R);ππ { Switch to 320x200x256 }ππ regs.ax := $0013;π intr($10, regs);ππ x := (-1) * R; { go from 0 - R to 0 }π temp := R * R;π Repeatπ y := sqrt(temp - (x * x));π putpixel((x0 + trunc(x)), (y0 - trunc(y)), 15); { 4.th quadrant }π putpixel((x0 - trunc(x)), (y0 - trunc(y)), 15); { 1.st quadrant }π putpixel((x0 + trunc(x)), (y0 + trunc(y)), 15); { 3.rd quadrant }π putpixel((x0 - trunc(x)), (y0 + trunc(y)), 15); { 2.nd quadrant }π x := x + 0.1; { change this if you want coarse or fine circle. }π Until (x >= 0.0);π c := ReadKey; { wait For keypress. }ππ { Switch back to Textmode. }ππ regs.ax := $0003;π intr($10, regs);πend.π 16 08-27-9320:25ALL MIKE BURNS Another Circle Routine IMPORT 11 ╓ {πMIKE BURNSππ> does someone have a circle routine for the 320x200x256 mode. I need oneπ> using the assembler... (FAST) ( or isn't that possible) I doesn't need toπ> be very perfect, if it has the shape of a circle, I'm satisfied.π}ππPROCEDURE SWAP(VAR A, B : Integer);πVarπ X : Integer;πBeginπ X := A;π A := B;π B := X;πEnd;ππVarπ SCR : Array [0..199, 0..319] of Byte Absolute $A000 : $0000;ππPROCEDURE Circle(X, Y, Radius : Word; Color: Byte);πVARπ a, af, b, bf,π target, r2 : Integer;πBeginπ Target := 0;π A := Radius;π B := 0;π R2 := Sqr(Radius);ππ While a >= B DOπ Beginπ b:= Round(Sqrt(R2 - Sqr(A)));π Swap(Target, B);π While B < Target Doπ Beginπ Af := (120 * a) Div 100;π Bf := (120 * b) Div 100;π SCR[x + af, y + b] := color;π SCR[x + bf, y + a] := color;π SCR[x - af, y + b] := color;π SCR[x - bf, y + a] := color;π SCR[x - af, y - b] := color;π SCR[x - bf, y - a] := color;π SCR[x + af, y - b] := color;π SCR[x + bf, y - a] := color;π B := B + 1;π End;π A := A - 1;π End;πEnd;ππbeginπ Asmπ Mov ax, $13π Int $10;π end;ππ Circle(50, 50, 40, $32);π Readln;ππ Asmπ Mov ax, $03π Int $10;π end;πend.ππππππ 17 08-27-9320:28ALL SEAN PALMER Simple coppering routineIMPORT 29 ╓ {πSEAN PALMERππ>Okay, I've got this small problem porting one of my assembler routinesπ>into pascal. It's a simple coppering routine (multiple setting of theπ>same palette register for trippy effects :), and i can't seem to use itπ>in my code.. I'll post the code here now (it's fairly short), and ifπ>someone could help me out here, i'd be most grateful - since myπ>assembler/pascal stuff isn't too great..ππI imported it, but couldn't get it to work (several problems in theπsource) and in the process of getting it to work (for one thing I didn'tπknow what it was supposed to accomplish in the first place) I added aπfew things to it and this probably isn't what you wanted it to look likeπbut it wouldn't be hard to do now that it's in TP-acceptable form.ππI also added one other small palette flipper that's kind of neat.π}ππ{$G+}πusesπ crt;ππprocedure copperBars(var colors; lines : word; regNum, count : byte); assembler;πvarπ c2 : byte;πasmπ{π okay, Colors is a pointer to the variable array ofπ colours to use (6bit rgb values to pump to the dac)π Lines is the number of scanlines on the screen (for syncing)π RegNum is the colour register (DAC) to use.π valid values are 0-255. that should explain that one.π Count is the number of cycles updates to do before it exits.π}π push dsππ mov ah, [RegNum]π mov dx, $3DA {vga status port}π mov bl, $C8 {reg for DAC}π cliπ cldππ @V1:π in al, dxπ test al, 8π jz @V1 {vertical retrace}π @V2:π in al, dxπ test al, 8π jnz @V2ππ mov c2, 1π mov di, [lines]ππ @UPDATER:π mov bh, c2π inc c2π lds si, [colors]π {now,just do it.}π @NIKE:π mov cx, 3π mov dl, $DAππ @H1:π in al, dxπ and al, 1π jz @H1 {horizontal retrace}ππ mov al, ah {color}π mov dl, blπ out dx, alπ inc dxπ rep outsb {186 instruction...}ππ mov dl, $DAπ @H2:π in al, dxπ and al, 1π jnz @H2;ππ dec diπ jz @Xπ dec bhπ jnz @NIKEπ jmp @UPDATERπ @X:π dec countπ jnz @V1π sti {enable interrupts}πEnd;ππprocedure freakout0(lines : word; count : byte); assembler;πasmπ mov dx, $3DA {vga status port}π cliπ cldππ @V1:π (* in al, dxπ test al, 8π jz @V1 {vertical retrace}π @V2:π in al, dxπ test al, 8π jnz @V2π *)ππ mov di,[lines]ππ @L:π mov dl, $C8π mov al, 0 {color}π out dx, alπ inc dxπ mov al, bhπ out dx, alπ add al, 20π out dx, alπ out dx, alπ add bh, 17π mov dl, $DAπ in al, dxπ test al, 1π jz @L; {until horizontal retrace}ππ dec diπ jnz @Lππ mov dl, $DAπ dec countπ jnz @V1π sti {enable interrupts}πEnd;ππconstπ pal : array [0..3 * 28 - 1] of byte =π (2,4,4,π 4,8,8,π 6,12,12,π 8,16,16,π 10,20,20,π 12,24,24,π 14,28,28,π 16,32,32,π 18,36,36,π 20,40,40,π 22,44,44,π 24,48,48,π 26,52,52,π 26,52,52,π 28,56,56,π 28,56,56,π 30,60,60,π 30,60,60,π 30,60,60,π 33,63,63,π 33,63,63,π 33,63,63,π 33,63,63,π 33,63,63,π 30,60,60,π 28,56,56,π 26,52,52,π 24,48,48);ππvarπ i : integer;ππbeginπ asmπ mov ax, $13π int $10π end;π for i := 50 to 149 doπ fillchar(mem[$A000 : i * 320 + 50], 220, 1);ππ repeatπ copperBars(pal, 398, 0, 8); {398 because of scan doubling}π until keypressed;π readkey;ππ repeatπ freakout0(398, 8); {398 because of scan doubling}π until keypressed;π readkey;ππ asmπ mov ax, 3π int $10π end;πend.π 18 08-27-9321:03ALL CHRIS BEISEL Screen Fades IMPORT 18 ╓ {πCHRIS BEISELππI've gotten many compliments on these two fade routines (a few goodπprogrammers thought they were asm!)... plus, I made them so you can fadeπpart on the palette also... It's very smooth on my 486, as well as 386'sπand 286's at friends houses...ππ set up in your type declarationsπ rgbtype=recordπ red,green,blue:byte;π end;π rgbarray[0..255] of rgbtype;ππ and in your var declarations have something likeπ rgbpal:rgbarray;ππ and set your colors in that...π}πprocedure fadein(fadepal : rgbarray; col1, col2 : byte);πvarπ lcv,π lcv2 : integer;π tpal : rgbarray;πbeginπ for lcv := col1 to col2 doπ beginπ TPal[lcv].red := 0;π TPal[lcv].green := 0;π TPal[lcv].blue := 0;π end;π for lcv := 0 to 63 doπ beginπ for lcv2:=col1 to col2 doπ beginπ if fadepal[lcv2].red > TPal[lcv2].red thenπ TPal[lcv2].red := TPal[lcv2].red + 1;π if fadepal[lcv2].green > TPal[lcv2].green thenπ TPal[lcv2].green := TPal[lcv2].green + 1;π if fadepal[lcv2].blue > TPal[lcv2].blue thenπ TPal[lcv2].blue := TPal[lcv2].blue+1;ππ setcolor(lcv2, TPal[lcv2].red, TPal[lcv2].green, TPal[lcv2].blue);π end;π refresh;π end;πend;ππ{*******************************************************************}ππprocedure fadeout(fadepal : rgbarray; col1, col2 : byte);πvarπ lcv,π lcv2 : integer;π TPal : rgbarray;πbeginπ for lcv := col1 to col2 doπ beginπ TPal[lcv].red := 0;π TPal[lcv].green := 0;π TPal[lcv].blue := 0;π end;π for lcv := 0 to 63 doπ beginπ for lcv2 := col1 to col2 doπ beginπ if fadepal[lcv2].red > TPal[lcv2].red thenπ fadepal[lcv2].red := fadepal[lcv2].red - 1;π if fadepal[lcv2].green > TPal[lcv2].green thenπ fadepal[lcv2].green := fadepal[lcv2].green - 1;π if fadepal[lcv2].blue > TPal[lcv2].blue thenπ fadepal[lcv2].blue := fadepal[lcv2].blue - 1;ππ setcolor(lcv2, fadepal[lcv2].red, fadepal[lcv2].green, fadepal[lcv2].blue);π end;π refresh;π end;πend;ππ{*******************************************************************}ππ 19 08-27-9321:25ALL ANDRE JAKOBS Graphic FX Unit IMPORT 318 ╓ {πI hope you can do something With these listingsπI downloaded from a BBS near me....πThis File contains: Program VGA3dπ Unit DDFigsπ Unit DDVarsπ Unit DDVideoπ Unit DDProcsπJust break it in pieces on the cut here signs......ππif you need some Units or Programs (or TxtFiles) on Programming the Adlib/πSound-Blaster or Roland MPU-401, just let me know, and i see if i can digπup some good listings.....πBut , will your game also have Soundblaster/adlib fm support and SoundπBlaster Digitized Sound support, maybe even MPU/MT32? support....πAnd try to make it as bloody as you can (Heads exploding etc..)(JOKE)ππI hope i you can complete your game (i haven't completed any of my games yet)πAnd i like a copy of it when it's ready......ππPlease leave a message if you received this File.ππ Andre Jakobsπ MicroBrain Technologies Inc.π GelderlandLaan 9π 5691 KL Son en Breugelπ The Netherlands............π}πππProgram animatie_van_3d_vector_grafics;ππUsesπ Crt,π ddvideo,π ddfigs,π ddprocs,π ddVars;ππVarπ Opal : paletteType;ππProcedure wireframe(pro : vertex2Array);π{ Teken een lijnen diagram van gesloten voorwerpen met vlakken }πVarπ i, j, k,π v1, v2 : Integer;πbeginπ For i := 1 to ntf DOπ beginπ j := nfac[i];π if j <> 0 thenπ beginπ v1 := faclist[ facfront[j] + size[j] ];π For k := 1 to size[j] DOπ beginπ v2 := faclist[facfront[j] + k];π if (v1<v2) or (super[i] <> 0 ) thenπ linepto(colour[j], pro[v1], pro[v2])π v1 := v2;π end;π end;π end;πend;ππProcedure hidden(pro : vertex2Array);π{ Display van Objecten als geheel van de projectiepunten van pro }π{ b is een masker voor de kleuren }πVarπ i, col : Integer;ππ Function signe( n : Real) : Integer;π beginπ if n >0 thenπ signe := -1π elseπ if n <0 thenπ signe := 1π elseπ signe := 0;π end;ππ Function orient(f : Integer; v : vertex2Array) : Integer;π Varπ i, ind1,π ind2, ind3 : Integer;π dv1, dv2 : vector2;π beginπ i := nfac[f];π if i = 0 thenπ orient := 0π elseπ beginπ ind1 := faclist[facfront[i] + 1];π ind2 := faclist[facfront[i] + 2];π ind3 := faclist[facfront[i] + 3];π dv1.x := v[ind2].x - v[ind1].x;π dv1.y := v[ind2].y - v[ind1].y;π dv2.x := v[ind3].x - v[ind2].x;π dv2.y := v[ind3].y - v[ind2].y;π orient := signe(dv1.x * dv2.y - dv2.x * dv1.y);π end;π end;ππ Procedure facetfill(k : Integer);π Varπ v : vector2Array;π i, index, j : Integer;π beginπ j := nfac[k];π For i := 1 to size[j] DOπ beginπ index := faclist[facfront[j] + i];π v[i] := pro[index];π end;π fillpoly(colour[k], size[j], v);π polydraw(colour[k] - 1, size[j], v);π end;ππ Procedure seefacet(k : Integer);π Varπ ipt, supk : Integer;π beginπ facetfill(k);π ipt := firstsup[k];π While ipt <> 0 DOπ beginπ supk := facetinfacet[ipt].info;π facetfill(supk);π ipt := facetinfacet[ipt].Pointer;π end;π end;ππ{ hidden Programmacode }πbeginπ For i := 1 to nof DOπ if super[i] = 0 thenπ if orient(i, pro) = 1 thenπ seefacet(i);πend;ππProcedure display;πVarπ i : Integer;πbeginπ {observe}π For i := 1 to nov DOπ transform(act[i], Q, obs[i]);ππ {project}π ntv := nov;π ntf := nof;π For i := 1 to ntv DOπ beginπ pro[i].x := obs[i].x;π pro[i].y := obs[i].y;π end;ππ {drawit}π switch := switch xor 1;π hidden(pro);π Scherm_actief(switch);π Virscherm_actief(switch xor 1);π wisscherm(prevpoints, $a000, $8a00);π wis_hline(prevhline, $8a00);π prevpoints := points;prevhline := hline;π points[0] := 0;π hline[0] := 0;πend;ππProcedure anim3d;πVarπ A, B, C, D, E, F,π G, H, I, J, QE, P : matrix4x4;π zoom, inz, inzplus : Real;π angle, angleinc,π beta, betainc, frame : Integer;π huidigpalette : paletteType;ππ { Kubus Animatie : Roterende kubus }π Procedure kubus;π beginπ angle := 0;π angleinc := 9;π beta := 0;π betainc := 2;π direct.x := 9;π direct.y := 2;π direct.z := -3;π findQ;π cubesetup(104);π frame := 0;ππ While (NOT (KeyPressed)) and (frame < 91) doπ beginπ frame := frame + 1;π xyscale := zoom * 2 * sinus(beta);π rot3(1, trunc(angle/2), Qe);π rot3(2, angle, P);π mult3(P, Qe, P);π cube(P);π display;π angle := angle + angleinc;π beta := beta + betainc;π nov := 0;π end;π end;ππ {Piramides Animatie : Scene opgebouwd uit twee Piramides en 1 Kubus }π Procedure Piramides;π beginπ frame := 0;π angle := 0;π beta := 0;π betainc := 2;π scale3(4.0, 0.2, 4.0, C);π cubesetup(90);π cube(P);ππ scale3(2.5, 4.0, 2.5, D);π tran3(2.0, -0.2, 2.0, E);π mult3(E, D, F);π pirasetup(34);π piramid(P);ππ scale3(2.0, 4.0, 2.0, G);π tran3(-3.0, -0.2, 0.0, H);π mult3(H, G, I);π pirasetup(42);π piramid(P);ππ E := Q;π nov := 0;ππ While (NOT (KeyPressed)) and (frame < 18) doπ beginπ frame := frame + 1;π xyscale := zoom * 2 * sinus(beta);ππ rot3(2, angle, B);ππ mult3(B, C, P);π cube(P);ππ mult3(B, F, P);π piramid(P);ππ mult3(B, I, P);π piramid(P);ππ display;ππ angle := angle + angleinc;π beta := beta + betainc;π nov := 0;π end;ππ frame := 0;π angleinc := 7;ππ While (NOT (KeyPressed)) and (frame < 75) doπ beginπ frame := frame + 1;ππ rot3(2, angle, B);ππ mult3(B, C, P);π cube(P);ππ mult3(B, F, P);π piramid(P);ππ mult3(B, I, P);π piramid(P);ππ display;ππ angle := angle + angleinc;π nov := 0;π end;ππ frame := 0;π beta := 180-beta;ππ While (NOT (KeyPressed)) and (frame < 19) doπ beginππ frame := frame + 1;ππ xyscale := zoom * 2 * sinus(beta);π rot3(2, angle, B);ππ mult3(C, B, P);π cube(P);ππ mult3(B, F, P);π piramid(P);ππ mult3(B, I, P);π piramid(P);ππ display;ππ angle := angle + angleinc;π beta := beta + betainc;π nov := 0;π end;π end;ππ { Huis_animatie4 : Figuur huis roteert en "komt uit de lucht vallen" }π Procedure huisval;π beginπ xyscale := zoom;π nof := 0;π nov := 0;π last := 0;π angle := 1355;π angleinc := -7;π frame := 0;ππ huissetup;ππ zoom := 0.02;π Direct.x := 30;π direct.y := -2;π direct.z := 30;π findQ;ππ While (NOT (KeyPressed)) and (frame < 40) doπ beginπ frame := frame + 1;π zoom := zoom + 0.01;π Scale3(zoom, zoom, zoom, Qe);π tran3(0, (-7 / zoom) + frame / 1.8, 0, A);π mult3(Qe, A, C);π rot3(2, angle, B);π mult3(C, B, P);π huis(P);π display;π angle := angle + angleinc;π nov := 0;π end;ππ frame := 0;π beta := angle;π betainc := angleinc;ππ While (NOT (KeyPressed)) and (frame < 15) doπ beginπ frame := frame + 1;ππ rot3(2, beta, B);π mult3(B, Qe, P);π mult3(P, A, P);π huis(P);ππ display;ππ beta := beta + betainc;π betainc := trunc(betainc + (7 / 15));π nov := 0;π end;ππ frame := 0;ππ While (NOT (KeyPressed)) and (frame < 30) doπ beginπ frame := frame + 1;π direct.z := direct.z - (frame * (20 / 70));π findQ;π huis(P);π display;π nov := 0;π end;ππ frame := 0;π zoom := 1;ππ While (NOT (KeyPressed)) and (frame < 31) doπ beginπ frame := frame + 1;π mult3(B, Qe, P);π scale3(zoom, zoom, zoom, C);π mult3(P, A, P);π mult3(P, C, P);π huis(P);π display;π zoom := zoom - 1 / 30;π nov := 0;π end;ππ zoom := xyscale;π end;ππ { Ster Animatie : Roterende ster als kubus met 4 piramides }π Procedure Sterrot;π beginπ xyscale := zoom;π frame := 0;π angle := 0;π angleinc := 9;π beta := 0;π betainc := 2;π nof := 0;π last := 0;π nov := 0;ππ stersetup(140);π scale3(0, 0, 0, P);π ster(P, 4);ππ Direct.x := 30;π direct.y := -2;π direct.z := 30;π findQ;π E := Q;ππ While (NOT (KeyPressed)) and (frame < 90) doπ beginπ frame := frame + 1;π xyscale := zoom * 1.7 * sinus(beta);π rot3(1, Round(angle/5), A);π mult3(A, E, Q);π rot3(2, angle, P);π ster(P, 4);π display;π angle := angle + angleinc;π beta := beta + betainc;π nov := 0;π end;π end;ππbeginπ eye.x := 0;π eye.y := 0;π eye.z := 0;π zoom := xyscale;π Repeatπ nov := 0;π nof := 0;π last := 0;π Kubus;π Piramides;π Huisval;π Sterrot;π Until KeyPressed;πend;ππ{ _______________Hoofd Programma --------------------- }ππbeginπ nov := 0;π nof := 0;π last := 0;π start('pira', 15, Opal);ππ points[0] := 0;π prevpoints[0] := 0;π hline[0] := 0;π prevhline[0] := 0;ππ anim3D;ππ finish(Opal);π Writeln('Coded by ...... " De Vectorman "');π Writeln;πend.πππ{ ▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒ }ππUnit ddfigs;ππInterfaceππUsesπ DDprocs, DDVars;ππConstπ cubevert : Array [1..8] of vector3 =π ((x : 1; y : 1; z : 1),π (x : 1; y : -1; z : 1),π (x : 1; y : -1; z : -1),π (x : 1; y : 1; z : -1),π (x : -1; y : 1; z : 1),π (x : -1; y : -1; z : 1),π (x : -1; y : -1; z : -1),π (x : -1; y : 1; z : -1));ππ cubefacet : Array [1..6, 1..4] of Integer =π ((1, 2, 3, 4),π (1, 4, 8, 5),π (1, 5, 6, 2),π (3, 7, 8, 4),π (2, 6, 7, 3),π (5, 8, 7, 6));ππ piravert : Array [1..5] of vector3 =π ((x : 0; y : 1; z : 0),π (x : 1; y : 0; z : -1),π (x : -1; y : 0; z : -1),π (x : -1; y : 0; z : 1),π (x : 1; y : 0; z : 1));ππ pirafacet : Array [1..5, 1..3] of Integer =π ((1, 2, 3),π (1, 3, 4),π (1, 4, 5),π (1, 5, 2),π (5, 4, 3));ππ huisvert : Array[1..59] of vector3 =π ((x : -6; y : 0; z : 4), (x : 6; y : 0; z : 4),π (x : 6; y : 0; z : -4),π (x : -6; y : 0; z : -4), (x : -6; y : 8; z : 4), (x : 6; y : 8; z : 4),π (x : 6; y : 11; z : 0), (x : 6; y : 8; z : -4), (x : -6; y : 8; z : -4),π (x : -6; y : 11; z : 0), (x : -4; y : 1; z : 4), (x : -1; y : 1; z : 4),π (x : -1; y : 3; z : 4), (x : -4; y : 3; z : 4), (x : -4; y : 5; z : 4),π (x : -1; y : 5; z : 4), (x : -1; y : 7; z : 4), (x : -4; y : 7; z : 4),π (x : 0; y : 0; z : 4), (x : 5; y : 0; z : 4), (x : 5; y : 4; z : 4),π (x : 0; y : 4; z : 4), (x : 1; y : 5; z : 4), (x : 4; y : 5; z : 4),π (x : 4; y : 7; z : 4), (x : 1; y : 7; z : 4), (x : 6; y : 5; z : -1),π (x : 6; y : 5; z : -3), (x : 6; y : 7; z : -3), (x : 6; y : 7; z : -1),π (x : 5; y : 1; z : -4), (x : 2; y : 1; z : -4), (x : 2; y : 3; z : -4),π (x : 5; y : 3; z : -4), (x : 5; y : 5; z : -4), (x : 2; y : 5; z : -4),π (x : 2; y : 7; z : -4), (x : 5; y : 7; z : -4), (x : 1; y : 0; z : -4),π (x : -1; y : 0; z : -4), (x : -1; y : 3; z : -4), (x : 0; y : 4; z : -4),π (x : 1; y : 3; z : -4), (x : -2; y : 1; z : -4), (x : -5; y : 1; z : -4),π (x : -5; y : 3; z : -4), (x : -2; y : 3; z : -4), (x : -2; y : 5; z : -4),π (x : -5; y : 5; z : -4), (x : -5; y : 7; z : -4), (x : -2; y : 7; z : -4),π (x : -6; y : 0; z : 1), (x : -6; y : 0; z : 3), (x : -6; y : 3; z : 3),π (x : -6; y : 3; z : 1), (x : -6; y : 5; z : 1), (x : -6; y : 5; z : 3),π (x : -6; y : 7; z : 3), (x : -6; y : 7; z : 1));ππ huissize : Array [1..19] of Integer =π (4, 4, 5, 4, 4, 5, 4, 4, 4, 4, 4, 4, 4, 4, 5, 4, 4, 4, 4);ππ huissuper : Array [1..19] of Integer =π (0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 3, 4, 4, 4, 4, 4, 6, 6);ππ huisfacet : Array [1..79] of Integer =π ( 1, 2, 6, 5,π 5, 6, 7, 10,π 2, 3, 8, 7,π 6, 3, 4, 9,π 8, 8, 9, 10,π 7, 4, 1, 5,π 10, 9, 4, 3,π 2, 1, 11, 12,π 13, 14, 15, 16,π 17, 18, 19, 20,π 21, 22, 23, 24,π 25, 26, 27, 28,π 29, 30, 31, 32,π 33, 34, 35, 36,π 37, 38, 39, 40,π 41, 42, 43, 44,π 45, 46, 47, 48,π 49, 50, 51, 52,π 53, 54, 55, 56,π 57, 58, 59);ππ stervert : Array [1..6] of vector3 =π ((x : 1; y : 0; z : 0),π (x : 0; y : 1; z : 0),π (x : 0; y : 0; z : 1),π (x : 0; y : 0; z : -1),π (x : 0; y : -1; z : 0),π (x : -1; y : 0; z : 0));ππProcedure cubesetup(c : Integer);πProcedure cube(P : matrix4x4);πProcedure pirasetup(c : Integer);πProcedure piramid(P : matrix4x4);πProcedure huissetup;πProcedure huis(P : matrix4x4);πProcedure hollow(P1 : matrix4x4);πProcedure stersetup(col : Integer);πProcedure ster(P : matrix4x4; d : Real);πProcedure ellips(P : matrix4x4; col : Integer);πProcedure goblet(P : matrix4x4; col : Integer);ππImplementationππProcedure cubesetup(c : Integer);π{ zet kubusdata in facetlist van de scene}πVarπ i, j : Integer;πbeginπ For i := 1 to 6 DOπ beginπ For j := 1 to 4 DOπ faclist[last + j] := cubefacet[i, j] + nov;π nof := nof + 1;π facfront[nof] := last;π colour[nof] := c;π nfac[nof] := nof;π super[nof] := 0;π firstsup[nof] := 0;π size[nof] := 4;π last := last + size[nof];π end;πend;ππProcedure cube(P : matrix4x4);πVarπ i, j : Integer;πbeginπ For i := 1 to 8 DOπ beginπ nov := nov + 1;π transform(cubevert[i], P, act[nov]);π end;πend;ππProcedure pirasetup(c : Integer);πVarπ i, j : Integer;πbeginπ For i := 1 to 5 DOπ beginπ For j := 1 to 3 DOπ faclist[last + j] := pirafacet[i, j] + nov;π nof := nof + 1;π facfront[nof] := last;π size[nof] := 3;π last := last + size[nof];π colour[nof] := c;π nfac[nof] := nof;π super[nof] := 0;π firstsup[nof] := 0;π end;ππ size[nof] := 4;π faclist[facfront[nof] + 4] := 2 + nov;π last := last + 1;πend;ππProcedure piramid(P : matrix4x4);πVarπ i, j : Integer;πbeginπ For i := 1 to 5 DOπ beginπ nov := nov + 1;π transform(piravert[i], P, act[nov]);π end;πend;πππProcedure huissetup;πVarπ i, j,π host,π nofstore : Integer;πbeginπ For i := 1 to 79 DOπ faclist[last + i] := huisfacet[i] + nov;ππ nofstore := nof;ππ For i := 1 to 19 DOπ beginπ nof := nof + 1;π facfront[nof] := last;π size[nof] := huissize[i];π last := last + size[nof];π nfac[nof] := nof;ππ if (i = 2) or (i = 5) thenπ colour[nof] := 111π elseπ if i = 7 thenπ colour[nof] := 20π elseπ if i < 8 thenπ colour[nof] := 42π elseπ colour[nof] := 25;ππ super[nof] := huissuper[i];π firstsup[nof] := 0;ππ if super[nof] <> 0 thenπ beginπ host := super[nof] + nofstore;π super[nof] := host;π pushfacet(firstsup[host], nof);π end;π end;π For i := 1 to 59 DOπ setup[i] := huisvert[i];πend;ππProcedure huis(P : matrix4x4);πVarπ i : Integer;πbeginπ For i := 1 to 59 DOπ beginπ nov := nov + 1;π transform(setup[i], P, act[nov]);π end;πend;πππProcedure hollow(P1 : matrix4x4);πVarπ A, B,π P, P2 : matrix4x4;π i : Integer;πbeginπ For i := 1 to 8 DOπ beginπ tran3(4.0 * cubevert[i].x, 4.0 * cubevert[i].y, 4.0 * cubevert[i].z, P2);π mult3(P1, P2, P);π cube(P);π end;ππ For i := 1 to 4 DOπ beginπ scale3(3.0, 1.0, 1.0, A);π tran3(0.0, 4.0 * cubevert[i].y, 4.0 * cubevert[i].z, B);π mult3(A, B, P2);mult3(P1, P2, P);π cube(P);π scale3(1.0, 3.0, 1.0, A);π tran3(4.0 * cubevert[i].y, 0.0, 4.0 * cubevert[i].z, B);π mult3(A, B, P2);mult3(P1, P2, P);π cube(P);π scale3(1.0, 1.0, 3.0, A);π tran3(4.0 * cubevert[i].z, 4.0 * cubevert[i].y, 0.0, B);π mult3(A, B, P2);mult3(P1, P2, P);π cube(P);π end;πend;ππProcedure stersetup(col : Integer);πVarπ i, j,π v1, v2 : Integer;πbeginπ For i := 1 to 6 DOπ beginπ v1 := cubefacet[i, 4] + nov;π For j := 1 to 4 DOπ beginπ v2 := cubefacet[i, j] + nov;π nof := nof + 1;π faclist[last + 1] := v1;π faclist[last + 2] := v2;π faclist[last + 3] := nov + 8 + i;π facfront[nof] := last;π size[nof] := 3;ππ last := last + size[nof];π colour[nof] := col;π nfac[nof] := nof;π super[nof] := 0;π firstsup[nof] := 0;π v1 := v2;π end;π end;πend;ππProcedure ster(P : matrix4x4; d : Real);πVarπ i, j,π v1, v2 : Integer;π A, S : matrix4x4;πbeginπ For i := 1 to 8 DOπ beginπ nov := nov + 1;π transform(cubevert[i], P, act[nov]);π end;ππ scale3(D, D, D, A);π mult3(A, P, S);ππ For i := 1 to 6 DOπ beginπ nov := nov + 1;π transform(stervert[i], S, act[nov]);π end;πend;ππProcedure ellips(P : matrix4x4; col : Integer);πVarπ v : vector2Array;π theta,π thetadiff,π i : Integer;πbeginπ theta := -90;π thetadiff := -9;π For i := 1 to 21 DOπ beginπ v[i].x := cosin(theta);π v[i].y := sinus(theta);π theta := theta + thetadiff;π end;π bodyofrev(P, col, 21, 20, v);πend;ππProcedure goblet(P : matrix4x4; col : Integer);πConstπ gobletdat : Array [1..12] of vector2 =π ((x : 0; y : -16),π (x : 8; y : -16),π (x : 8; y : -15),π (x : 1; y : -15),π (x : 1; y : -2),π (x : 6; y : -1),π (x : 8; y : 2),π (x : 14; y : 14),π (x : 13; y : 14),π (x : 7; y : 2),π (x : 5; y : 0),π (x : 0; y : 0));ππVarπ gobl : vector2Array;π i : Integer;πbeginπ For i := 1 to 12 DOπ gobl[i] := gobletdat[i];π bodyofrev(P, col, 12, 20, gobl)πend;ππbegin;πend.πππ{ ▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒ }ππUnit ddprocs;ππInterfaceππUsesπ DDVars;ππConstπ maxv = 200;π maxf = 400;π maxlist = 1000;π vectorArraysize = 32;π sizeofpixelArray = 3200;π sizeofhlineArray = 320 * 4;ππTypeπ vector2 = Record x, y : Real; end;π vector3 = Record x, y, z : Real; end;π pixelvector = Record x, y : Integer; end;π pixelArray = Array [0..sizeofpixelArray] of Integer;π hlineArray = Array [0..sizeofhlineArray] of Integer;π vector3Array = Array [1..vectorArraysize] of vector3;π matrix3x3 = Array [1..3, 1..3] of Real;π matrix4x4 = Array [1..4, 1..4] of Real;π vertex3Array = Array [1..maxv] of vector3;π vertex2Array = Array [1..maxv] of vector2;π vector2Array = Array [1..vectorArraysize ] of vector2;π facetArray = Array [1..maxf] of Integer;π facetlist = Array [1..maxlist] of Integer;ππConstπ EenheidsM : matrix4x4 =π ((1, 0, 0, 0),π (0, 1, 0, 0),π (0, 0, 1, 0),π (0, 0, 0, 1));πVarπ Q : matrix4x4;π eye, direct : vector3;π nov, ntv,π ntf, nof,π last : Integer;π setup,π act, obs : vertex3Array;π pro : vertex2Array;π faclist : facetlist;π colour,π size,π facfront,π nfac,π super,π firstsup : facetArray;π points,π prevpoints : pixelArray;π hline,π prevhline : hlineArray;ππProcedure tran3(tx, ty, tz : Real; Var A : matrix4x4);πProcedure scale3(sx, sy, sz : Real; Var A : matrix4x4);πProcedure rot3(m : Integer; theta : Integer; Var A : matrix4x4);πProcedure mult3(A, B : matrix4x4; Var C : matrix4x4);πProcedure findQ;πProcedure genrot(phi : Integer; b, d : vector3; Var A : matrix4x4);πProcedure transform(v : vector3; A : matrix4x4; Var w : vector3);πProcedure extrude(P : matrix4x4; d : Real; col, n : Integer;π v : vector2Array);πProcedure bodyofrev(P : matrix4x4; col, nvert, nhoriz : Integer;π v : vector2Array);πProcedure polydraw(c, n : Integer; poly : vector2Array);πProcedure linepto(c : Integer; pt1, pt2 : vector2);πProcedure WisScherm(punten : pixelArray; SchermSeg, VirSeg : Word);πProcedure fillpoly(c, n : Integer; poly : vector2Array);πProcedure Wis_Hline(hline_ar : hlineArray; virseg : Word);ππImplementationππProcedure tran3(tx, ty, tz : Real; Var A : matrix4x4);π{ zet matrix A op punt tx, ty, tz }πbeginπ A := EenheidsM;π A[1, 4] := -tx;π A[2, 4] := -ty;π A[3, 4] := -tz;πend;ππProcedure scale3(sx, sy, sz : Real; Var A : matrix4x4);π{ zet matrix A om in schaal van sx, sy, sz }πbeginπ A := EenheidsM;π A[1, 1] := sx;π A[2, 2] := sy;π A[3, 3] := sz;πend;ππProcedure rot3(m : Integer; theta : Integer; Var A : matrix4x4);π{ roteer matrix A om m: 1=x-as; 2=y-as; 3=z-as met hoek theta (in graden)}πVarπ m1, m2 : Integer;π c, s : Real;πbeginπ A := EenheidsM;π m1 := (m MOD 3) + 1;π m2 := (m1 MOD 3) + 1;π c := cosin(theta);π s := sinus(theta);π A[m1, m1] := c;π A[m2, m2] := c;π A[m1, m2] := s;π A[m2, m1] := -s;πend;ππProcedure mult3(A, B : matrix4x4; Var C : matrix4x4);π{ vermenigvuldigd matrix A en B naar matrix C }πVarπ i, j, k : Integer;π ab : Real;πbeginπ For i := 1 to 4 doπ For j := 1 to 4 doπ beginπ ab := 0;π For k := 1 to 4 doπ ab := ab + A[i, k] * B[k, j];π C[i, j] := ab;π end;πend;ππProcedure findQ;π{ Bereken de Observatie-matrix 'Q' voor een punt in de ruimte }πVarπ E, F, G,π H, U : matrix4x4;π alpha,π beta,π gamma : Integer;π v, w : Real;πbeginπ tran3(eye.x, eye.y, eye.z, F);ππ alpha := angle(-direct.x, -direct.y);π rot3(3, alpha, G);ππ v := sqrt( (direct.x * direct.x) + (direct.y * direct.y));π beta := angle(-direct.z, v);π rot3(2, beta, H);ππ w := sqrt( (v * v) + (direct.z * direct.z));π gamma := angle( -direct.x * w, direct.y * direct.z);π rot3(3, gamma, U);ππ mult3(G, F, Q);π mult3(H, Q, E);π mult3(U, E, Q);πend;ππProcedure genrot (phi : Integer; b, d : vector3; Var A : matrix4x4);πVarπ F, G, H,π W, FI, GI,π HI, S, T : matrix4x4;π v : Real;π beta,π theta : Integer;πbeginπ tran3(b.x, b.y, b.z, F);π tran3(-b.x, -b.y, -b.z, FI);π theta := angle(d.x, d.y);π rot3(3, theta, G);π rot3(3, -theta, GI);π v := sqrt(d.x * d.x + d.y * d.y);π beta := angle(d.z, v);π rot3(2, beta, H);π rot3(2, -beta, HI);π rot3(2, beta, H);π rot3(2, -beta, HI);π rot3(3, phi, W);π mult3(G, F, S);π mult3(H, S, T);π mult3(W, S, T);π mult3(HI, S, T);π mult3(GI, T, S);π mult3(FI, S, A);πend;ππProcedure transform(v : vector3; A : matrix4x4; Var w : vector3);π{ transformeer colomvector 'v' uit A in colomvector 'w'}πbeginπ w.x := A[1, 1] * v.x + A[1, 2] * v.y + A[1, 3] * v.z + A[1, 4];π w.y := A[2, 1] * v.x + A[2, 2] * v.y + A[2, 3] * v.z + A[2, 4];π w.z := A[3, 1] * v.x + A[3, 2] * v.y + A[3, 3] * v.z + A[3, 4];πend;ππProcedure extrude(P : matrix4x4; d : Real; col, n : Integer;π v : vector2Array);π{ Maakt van een 2d-figuur een 3d-figuur }π{ vb: converteert 2d-letters naar 3d-letters }πVarπ i, j,π lasti : Integer;π v3 : vector3;πbeginπ For i := 1 to n DOπ beginπ faclist[last + i] := nov + i;π faclist[last + n + i] := nov + 2 * n + 1 - i;π end;π facfront[nof + 1] := last;π facfront[nof + 2] := last + n;π size[nof + 1] := n;π size[nof + 2] := n;π nfac[nof + 1] := nof + 1;π nfac[nof + 2] := nof + 2;π super[nof + 1] := 0;π super[nof + 2] := 0;π firstsup[nof + 1] := 0;π firstsup[nof + 2] := 0;π colour[nof + 1] := col;π colour[nof + 2] := col;π last := last + 2 * n;π nof := nof + 2;π lasti := n;ππ For i := 1 to n DOπ beginπ faclist[last + 1] := nov + i;π faclist[last + 2] := nov + lasti;π faclist[last + 3] := nov + n + lasti;π faclist[last + 4] := nov + n + i;π nof := nof + 1 ;π facfront[nof] := last;π size[nof] := 4;π nfac[nof] := nof;π super[nof] := 0;π firstsup[nof] := 0;π colour[nof] := col;π last := last + 4;π lasti := i;π end;π For i := 1 To n DOπ beginπ v3.x := v[i].x;π v3.y := v[i].y;π v3.z := 0.0;π nov := nov + 1;π transform(v3, P, act[nov]);π v3.z := -d;π transform(v3, P, act[nov + n]);π end;π nov := nov + n;πend;ππProcedure bodyofrev(P : matrix4x4; col, nvert, nhoriz : Integer;π v : vector2Array);π{ maakt een "rond" figuur van een 2-dimensionale omlijning van het figuur }πVarπ theta,π thetadiff,π i, j, newnov : Integer;π c, s : Array [1 .. 100] of Real;π index1,π index2 : Array [1 .. 101] of Integer;πbeginπ theta := 0;π thetadiff := trunc(360 / nhoriz);ππ For i := 1 to nhoriz DOπ beginπ c[i] := cosin(theta);π s[i] := sinus(theta);π theta := theta + thetadiff;π end;π newnov := nov;ππ if abs(v[1].x) < epsilon thenπ beginπ newnov := newnov + 1;π setup[newnov].x := 0.0;π setup[newnov].y := v[1].y;π setup[newnov].z := 0.0;π For i := 1 to nhoriz + 1 DOπ index1[i] := newnov;π endπ elseπ beginπ For i := 1 to nhoriz DOπ beginπ newnov := newnov + 1;π setup[newnov].x := v[1].x * c[i];π setup[newnov].y := v[1].y;π setup[newnov].z := -v[1].x * s[i];π index1[i] := newnov;π end;π index1[nhoriz + 1] := index1[i];π end;ππ For j := 2 to nvert DOπ beginπ if abs(v[j].x) < epsilon thenπ beginπ newnov := newnov + 1;π setup[newnov].x := 0.0;π setup[newnov].y := v[j].y;π setup[newnov].z := 0.0;π For i := 1 to nhoriz + 1 DOπ index2[i] := newnov;π endπ elseπ beginπ For i := 1 To nhoriz DOπ beginπ newnov := newnov + 1;π setup[newnov].x := v[j].x * c[i];π setup[newnov].y := v[j].y;π setup[newnov].z := -v[j].x * s[i];π index2[i] := newnov;π end;π index2[nhoriz + 1] := index2[1];π end;ππ if index1[1] <> index1[2] thenπ if index2[1] = index2[2] thenπ beginπ For i := 1 to nhoriz DOπ beginπ nof := nof + 1; size[nof] := 3;π facfront[nof] := last;π faclist[last + 1] := index1[i + 1];π faclist[last + 2] := index2[i];π faclist[last + 3] := index1[i];π last := last + size[nof];π nfac[nof] := nof;π colour[nof] := col;π super[nof] := 0;π firstsup[nof] := 0;π end;π endπ elseπ beginπ For i := 1 to nhoriz DOπ beginπ nof := nof + 1;π size[nof] := 4;π facfront[nof] := last;π faclist[last + 1] := index1[i + 1];π faclist[last + 2] := index2[i + 2];π faclist[last + 3] := index2[i];π faclist[last + 4] := index1[i];π last := last + size[nof];π nfac[nof] := nof;π colour[nof] := col;π super[nof] := 0;π firstsup[nof] := 0;π end;π endπ elseπ if index2[1] <> index2[2] thenπ For i := 1 to nhoriz DOπ beginπ nof := nof + 1;π size[nof] := 3;π facfront[nof] := last;π faclist[last + 1] := index2[i + 1];π faclist[last + 2] := index2[i];π faclist[last + 3] := index1[i];π last := last + size[nof];π nfac[nof] := nof;π colour[nof] := col;π super[nof] := 0;π firstsup[nof] := 0;π end;ππ For i := 1 to nhoriz + 1 DOπ index1[i] := index2[i];π end;ππ For i := nov + 1 to newnov DOπ transform(setup[i], P, act[i]);ππ nov := newnov;ππend;ππProcedure BressenHam( Virseg : Word; { Adres-> VIRSEG:0 }π pnts : pixelArray;π c : Byte; { c-> kleur }π p1, p2 : pixelvector); { vector } Assembler;πVarπ x, y, error,π s1, s2,π deltax,π deltay, i : Integer;π interchange : Boolean;π dcolor : Word;πAsmπ{ initialize Variables }π PUSH dsπ LDS si, pntsπ MOV ax, virsegπ MOV es, axπ MOV cx, 320π MOV ax, p1.xπ MOV x, axπ MOV ax, p1.yπ MOV y, axπ MOV dcolor, axππ MOV ax, p2.x { deltax := abs(x2 - x1) }π SUB ax, p1.x { s1 := sign(x2 - x1) }π PUSH axπ PUSH axπ CALL ddVars.signπ MOV s1, ax;π POP axπ TEST ax, $8000π JZ @@GeenSIGN1π NEG axπ @@GeenSign1:π MOV deltax, axπ MOV ax, p2.yπ SUB ax, p1.yπ PUSH axπ PUSH axπ CALL ddVars.signπ MOV s2, axπ POP axπ TEST ax, $8000π JZ @@GeenSign2π NEG axπ @@GeenSign2:π MOV deltay, axππ { Interchange DeltaX and DeltaY depending on the slope of the line }ππ MOV interchange, Falseπ CMP ax, deltaxπ JNG @@NO_INTERCHANGEπ XCHG ax, deltaxπ XCHG ax, deltayπ MOV interchange, Trueππ @@NO_INTERCHANGE:ππ { Initialize the error term to compensate For a nonzero intercept }ππ MOV ax, deltaYπ SHL ax, 1π SUB ax, deltaXπ MOV error, axππ { Main loop }π MOV ax, 1π MOV i, axπ @@FOR_begin:π CMP ax, deltaXπ JG @@EINDE_FOR_LOOPππ { Plot punt! }π MOV bx, xπ MOV ax, yπ MUL cxπ ADD bx, axπ MOV al, cπ MOV Byte PTR [es:bx], alπ INC [Word ptr ds:si] { aantal verhogen }π MOV ax, [si]π SHL ax, 1 { offset berekenen }π PUSH siπ ADD si, axπ MOV [si], bxπ POP siππ { While Loop }π @@W1_begin:π CMP error, 0π JL @@EINDE_WHILEππ { if interchange then }ππ CMP interchange, Trueπ JE @@i_is_tπ MOV ax, s2π ADD y, axπ JMP @@w1_eruitππ @@i_is_t:π MOV ax, s1π ADD x, axππ @@w1_eruit:π MOV ax, deltaxπ SHL ax, 1π SUB error, axπ JMP @@w1_beginππ @@EINDE_WHILE:π CMP interchange, Trueπ JE @@i_is_t_1π MOV ax, s1π ADD x, axπ JMP @@if_2_eruitππ @@i_is_t_1:π MOV ax, s2π ADD y, axππ @@if_2_eruit:π MOV ax, deltayπ SHL ax, 1π ADD error, axπ INC iπ MOV ax, iπ JMP @@FOR_beginπ @@Einde_for_loop:π POP dsπend;ππProcedure linepto(c : Integer; pt1, pt2 : vector2);πVarπ p1, p2 : pixelvector;πbeginπ p1.x := fx(pt1.x);π p1.y := fy(pt1.y);π p2.x := fx(pt2.x);π p2.y := fy(pt2.y);π BressenHam($a000, points, c, p1, p2);πend;ππProcedure WisScherm(punten : pixelArray; SchermSeg , Virseg : Word); Assembler;πAsmπ PUSH dsπ MOV ax, SchermSegπ MOV es, axπ LDS bx, puntenπ MOV cx, [bx]π JCXZ @@NietTekenenπ @@Wis:π INC bxπ INC bxπ MOV si, [bx]π MOV di, siπ PUSH dsπ MOV ax, virsegπ MOV ds, axπ MOVSBπ POP dsπ LOOP @@Wisπ @@NietTekenen:π POP dsπend;ππProcedure polydraw(c, n : Integer; poly : vector2Array);πVarπ i : Integer;πbeginπ For i := 1 to n - 1 doπ linepto(c, poly[i], poly[i + 1]);π linepto(c, poly[n], poly[1]);πend;ππProcedure fillpoly(c, n : Integer; poly : vector2Array);πVarπ scan_table : tabel;π scanline,π line,π offsetx : Integer;ππ Procedure Draw_horiz_line(hline_ar : hlineArray;π color : Byte;π lijn : Word;π begin_p : Word;π linelen : Word); Assembler;π Asmπ PUSH dsπ MOV cx, 320π MOV ax, 0a000hπ MOV es, axπ MOV di, begin_pπ MOV ax, lijnπ MUL cxπ ADD di, axπ PUSH diπ MOV al, colorπ MOV cx, linelenπ PUSH cxπ REP STOSBπ LDS si, hline_arπ INC [Word ptr ds:si]π MOV ax, [si]π SHL ax, 1π SHL ax, 1π ADD si, axπ POP bxπ POP dxπ MOV [si], dxπ MOV [si + 2], bxπ POP dsπ end;ππ Procedure swap(Var x, y : Integer);π beginπ x := x + y;π y := x - y;π x := x - y;π end;ππ{πProcedure Calc_x(x1, y1, x2, y2 : Word; Var scan_table : tabel);πVarπ m_inv,π xReal : Real;πbeginπ Asmπ LDS dx, scan_tableπ MOV ax, y1π MOV bx, y2π CMP ax, bxπ JNE @@NotHorizLineπ MOV bx, x1π SHL ax, 1π ADD ax, dxπ CMP bx, [dx]π JGE @@Notstorexminπ MOV [dx], bxππ @@Notstorexmin:π INC dxπ MOV bx, x2π CMP bx, [dx]π JLE @@Klaarπ MOV [dx], bxπ JMP @@Klaarππ @@NotHorizLine:π}ππ Procedure Calc_x(x1, y1, x2, y2 : Integer; Var scan_table : tabel);π Varπ m_inv, xReal : Real;π i, y, temp : Integer;π beginπ if y1 = y2 thenπ beginπ if x2 < x1 thenπ swap(x1, x2)π elseπ beginπ if x1 < scan_table[y1].xmin thenπ scan_table[y1].xmin := x1;π if x2 > scan_table[y2].xmax thenπ scan_table[y2].xmax := x2;π end;π endπ elseπ beginπ m_inv := (x2 - x1) / (y2 - y1);ππ if y1 > y2 then {swap}π beginπ swap(y1, y2);π swap(x1, x2);π end;ππ if x1 < scan_table[y1].xmin thenπ scan_table[y1].xmin := x1;π if x2 > scan_table[y2].xmax thenπ scan_table[y2].xmax := x2;π xReal := x1; y := y1;ππ While y < y2 doπ beginπ y := y + 1;π xReal := xReal + m_inv;π offsetx := round(xReal);π if xReal < scan_table[y].xmin thenπ scan_table[y].xmin := offsetx;π if xReal > scan_table[y].xmax thenπ scan_table[y].xmax := offsetx;π end;π end;π end;ππbeginπ scan_table := emptytabel;π For line := 1 to n - 1 doπ calc_x(fx(poly[line].x), fy(poly[line].y),π fx(poly[line + 1].x), fy(poly[line + 1].y), scan_table);ππ calc_x(fx(poly[n].x), fy(poly[n].y),π fx(poly[1].x), fy(poly[1].y), scan_table);ππ scanline := 0;ππ While scanline < nypix - 1 doπ beginπ With Scan_table[scanline] DOπ if xmax > xmin thenπ draw_horiz_line(hline, c, scanline, xmin, xmax - xmin + 1);π scanline := scanline + 1;π end;πend;ππProcedure Wis_Hline(hline_ar : hlineArray; virseg : Word); Assembler;πAsmπ PUSH dsπ MOV ax, 0a000hπ MOV es, axπ LDS bx, hline_arπ MOV cx, [bx]π JCXZ @@Niet_tekenenπ ADD bx, 4π @@Wis:π XCHG cx, dxπ MOV si, [bx]π MOV cx, [bx + 2]π MOV di, siπ PUSH dsπ MOV ax, virsegπ MOV ds, axπ CLDπ REP MOVSBπ POP dsπ XCHG cx, dxπ ADD bx, 4π LOOP @@Wisπ @@Niet_tekenen:π POP dsπend;ππbeginπend.πππ{ ▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒ }ππUnitπ ddVars;ππInterfaceππConstπ pi = 3.1415926535;π epsilon = 0.000001;π rad = pi / 180;π nxpix = 320; { scherm resolutie }π nypix = 200;π maxfinf = 200;ππTypeπ xmaxymax = Record xmin, xmax : Integer; end;π facetinfo = Record info, Pointer : Integer; end;π tabel = Array [1..nypix - 1] of xmaxymax;π sincos = Array [0..359] of Real;ππVarπ sinusArray : sincos;π cosinusArray : sincos;π facetinfacet : Array [1..maxfinf] of facetinfo;π facetfree : Integer;π xyscale : Real;π emptytabel : tabel;ππFunction fx(x : Real) : Integer;πFunction fy(y : Real) : Integer;πFunction Sign(I : Integer) : Integer;πFunction macht(a, n : Real) : Real;πFunction angle(x, y : Real) : Integer;πFunction sinus(hoek : Integer) : Real;πFunction cosin(hoek : Integer) : Real;πProcedure pushfacet(Var stackname : Integer; value : Integer);ππImplementationππFunction fx(x : Real) : Integer;πbeginπ fx := nxpix - trunc(x * xyscale + nxpix * 0.5 - 0.5);πend;ππFunction fy(y : Real) : Integer;πbeginπ fy := nypix - trunc(y * xyscale + nypix * 0.5 - 0.5);πend;ππFunction Sign(I : Integer) : Integer; Assembler;πAsmπ MOV ax, iπ CMP ax, 0π JGE @@Zero_or_oneπ MOV ax, -1π JMP @@Exitππ @@Zero_or_One:π JE @@Nulπ MOV ax, 1π JMP @@Exitππ @@Nul:π xor ax, axππ @@Exit:πend;ππFunction macht(a, n : Real) : Real;πbeginπ if a > 0 thenπ macht := exp(n * (ln(a)))π elseπ if a < 0 thenπ macht := -exp(n * (ln(-a)))π elseπ macht := a;πend;ππFunction angle(x, y : Real) : Integer;πbeginπ if abs(x) < epsilon thenπ if abs(y) < epsilon thenπ angle := 0π elseπ if y > 0.0 thenπ angle := 90π elseπ angle := 270π elseπ if x < 0.0 thenπ angle := round(arctan(y / x) / rad) + 180π elseπ angle := round(arctan(y / x) / rad);πend;ππFunction sinus(hoek : Integer) : Real;πbeginπ hoek := hoek mod 360;π sinus := sinusArray[hoek];πend;ππFunction cosin(hoek : Integer) : Real;πbeginπ hoek := hoek mod 360 ;π cosin := cosinusArray[hoek];πend;ππProcedure pushfacet(Var stackname : Integer; value : Integer);πVarπ location : Integer;πbeginπ if facetfree = 0 thenπ beginπ Write('Cannot hold more facets');π HALT;π endπ elseπ beginπ location := facetfree;π facetfree := facetinfacet[facetfree].Pointer;π facetinfacet[location].info := value;π facetinfacet[location].Pointer := stackname;π stackname := location;π end;πend;ππVarπ i : Integer;πbeginπ { vul sinus- en cosinusArray met waarden }π For i := 0 to 359 DOπ beginπ sinusArray[i] := sin(i * rad);π cosinusArray[i] := cos(i * rad);π end;π { Init facetinfacet }π facetfree := 1;π For i := 1 to maxfinf - 1 DOπ facetinfacet[i].Pointer := i + 1;ππ facetinfacet[maxfinf].Pointer := 0;ππ { Init EmptyTabel }π For i := 0 to nypix - 1 DOπ beginπ Emptytabel[i].xmin := 319;π Emptytabel[i].xmax := 0;π end;πend.πππ{ ▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒ }ππUnit ddvideo;ππInterfaceππUsesπ Dos, DDVars;ππTypeπ schermPointer = ^schermType;π schermType = Array [0..nypix - 1, 0..nxpix - 1] of Byte;π color = Record R, G, B : Byte; end;π paletteType = Array [0..255] of color;π WordArray = Array [0..3] of Word;π palFile = File of paletteType;π picFile = File of schermType;ππVarπ scherm : schermType Absolute $8A00 : $0000;π schermptr : schermPointer;π switch : Integer;ππProcedure start(Filenaam : String; horiz : Real; Var Oldpal : paletteType);πProcedure finish(Oldpal : paletteType);πProcedure VirScherm_actief(switch : Word);πProcedure Scherm_actief(switch : Word);ππImplementationππProcedure Virscherm_actief(switch : Word); Assembler;πAsmπ MOV dx, 3cchπ MOV cx, switchπ JCXZ @@volgendeπ in al, dx { switch=1 }π and al, 0dfhπ MOV dx, 3c2hπ OUT dx, al { set even mode }π JMP @@Klaarππ @@Volgende:π in al, dx { switch=0 }π or al, 20hπ MOV dx, 3c2hπ OUT dx, al { set odd mode }ππ @@Klaar:π MOV dx, 3dah { Wacht op Vert-retrace }π in al, dx { Zodat virscherm = invisible }π TEST al, 08hπ JZ @@Klaarπend;ππProcedure Scherm_actief(switch : Word);πbeginπ Asmπ @@Wacht:π MOV dx, 3dahπ in al, dxπ TEST al, 01hπ JNZ @@Wachtπ end;π port[$3d4] := $c;π port[$3d5] := switch * $80;πend;ππProcedure SetVgaPalette(Var p : paletteType);πVarπ regs : Registers;πbeginπ With regs doπ beginπ ax := $1012;π bx := 0;π cx := 256;π es := seg(p);π dx := ofs(p);π end;π intr ($10, regs);πend;πππProcedure start(Filenaam : String; horiz : Real; Var Oldpal : paletteType);ππ Procedure readimage(Filenaam : String; Var pal : paletteType);ππ Function FileExists(FileName : String) : Boolean;π Varπ f : File;π beginπ {$I-}π Assign(f, FileName);π Reset(f);π Close(f);π {$I + }π FileExists := (IOResult = 0) and (FileName <> '');π end;ππ Varπ pFile : picFile;π lFile : palFile;π a : Integer;π beginπ if (FileExists(Filenaam + '.pal')) andπ (FileExists(Filenaam + '.dwg')) thenπ beginπ assign(lFile, Filenaam + '.pal');π reset(lFile);π read(lFile, pal);π close(lFile);π assign(pFile, Filenaam + '.dwg');π reset(pFile);π read(pFile, schermptr^);π close(pFile);π endπ elseπ beginπ Writeln('Palette en Picture bestanden niet gevonden....');π Halt;π end;π end;ππ Procedure SetVgaMode; Assembler;π Asmπ mov ah, 0π mov al, 13hπ int $10π end;ππ Procedure GetVgaPalette(Var p : paletteType);π Varπ regs : Registers;π beginπ With regs doπ beginπ ax := $1017;π bx := 0;π cx := 256;π es := seg(p);π dx := ofs(p);π end;π intr ($10, regs);π end;ππVarπ pal : paletteType;ππbeginπ getmem(schermptr, sizeof(schermType));π readimage(Filenaam, pal);π GetVgaPalette(OldPal);π SetVgaPalette(pal);π SetVgaMode;π move(schermptr^, scherm, nypix * nxpix);π Virscherm_actief(0);π move(schermptr^, mem[$A000 : 0], nypix * nxpix); { blanko scherm }π VirScherm_actief(1);π move(schermptr^, mem[$A000 : 0], nypix * nxpix); { blanko scherm }π Scherm_actief(1);π switch := 0;π xyscale := (nypix - 1) / horiz;πend;ππProcedure finish(Oldpal : paletteType);ππ Procedure SetNormalMode; Assembler;π Asmπ mov ah, 0π mov al, 3π int $10π end;ππbeginπ SetVgaPalette(Oldpal);π SetNormalMode;π Virscherm_actief(0);π Freemem(schermptr, sizeof(schermType));πend;ππbeginπend.π 20 08-27-9321:27ALL SWAG SUPPORT TEAM A Simple Graph Unit IMPORT 12 ╓ Unit MyGraph;ππInterfaceππTypeπ ColorValue = Recordπ Rvalue,π Gvalue,π Bvalue : Byte;π end;ππ PaleteType = Array [0..255] of ColorValue;ππProcedure palette(tp : paleteType);πProcedure pset(x, y : Integer; c : Byte);πFunction Point(x, y : Integer) : Byte;πProcedure RotatePalette(Var p : PaleteType; n1, n2, d : Integer);πProcedure SetVga;ππImplementationππUsesπ Crt, Dos;ππππVarπ n, x,π y, c, i : Integer;π ch : Char;π p : PaleteType;π image : File;π ok : Boolean;ππProcedure palette(tp : PaleteType);πVarπ regs : Registers;πbegin { Procedure VGApalette }π Regs.AX := $1012;π Regs.BX := 0; { first register to set }π Regs.CX := 256; { number of Registers to set }π Regs.ES := Seg(tp);π Regs.DX := Ofs(tp);π Intr($10, regs);πend; { Procedure SetVGApalette }ππProcedure Pset(x, y : Integer; c : Byte);πbegin { Procedure PutPixel }π mem[$A000 : Word(320 * y + x)] := c;πend; { Procedure PutPixel }ππFunction point(x, y : Integer) : Byte;πbegin { Function GetPixel }π Point := mem[$A000 : Word(320 * y + x)];πend; { Function GetPixel }ππProcedure rotatePalette(Var p : PaleteType; n1, n2, d : Integer);πVarπ q : PaleteType;πbegin { Procedure rotatePalette }π q := p;π For i := n1 to n2 doπ p[i] := q[n1 + (i + d) mod (n2 - n1 + 1)];π palette(p);πend; { Procedure rotatePalette }ππProcedure SetVga;πbeginπ Inline($B8/$13/$00/$CD/$10);πend;ππend.ππ 21 08-27-9321:37ALL MARK DIXON ModeX Code IMPORT 41 ╓ {πMARK DIXONππUm, have a look at this, and see what you can come up with. It's some code Iπwrote a while back to use mode-x and do double buffering (or page-flipping).π}ππProgram Test_ModeX;ππUsesπ crt;πππ{ This program will put the VGA card into a MODEX mode (still only 320x200)π and demonstrate double buffering (page flipping)ππ This program was written by Mark Dixon, and has been donated to theπ Public Domain with the exception that if you make use of these routines,π the author of these routines would appreciate his name mentioned somewhereπ in the documentation.ππ Use these routines at your own risk! Because they use the VGA's registers,π cards that are not 100% register compatible may not function correctly, andπ may even be damaged. The author will bear no responsability for any actionsπ occuring as a direct (or even indirect) result of the use of this program.ππ Any donations (eg Money, Postcards, death threats.. ) can be sent to :ππ Mark Dixonπ 12 Finchley Stπ Lynwood,π Western Australiaπ 6147ππ If you have Netmail access, then I can also be contacted on 3:690/660.14ππ }ππConstπ Page : Byte = 0;ππVarπ I, J : Word;πππProcedure InitModeX;π{ Sets up video mode to Mode X (320x200x256 with NO CHAIN4) making availableπ 4 pages of 4x16k bitmaps }πBeginπ asmπ mov ax, 0013h { Use bios to enter standard Mode 13h }π int 10hπ mov dx, 03c4h { Set up DX to one of the VGA registers }π mov al, 04h { Register = Sequencer : Memory Modes }π out dx, alπ inc dx { Now get the status of the register }π in al, dx { from the next port }π and al, 0c7h { AND it with 11000111b ie, bits 3,4,5 wiped }π or al, 04h { Turn on bit 2 (00000100b) }π out dx, al { and send it out to the register }π mov dx, 03c4h { Again, get ready to activate a register }π mov al, 02h { Register = Map Mask }π out dx, alπ inc dxπ mov al, 0fh { Send 00001111b to Map Mask register }π out dx, al { Setting all planes active }π mov ax, 0a000h { VGA memory segment is 0a000h }π mov es, ax { load it into ES }π sub di, di { clear DI }π mov ax, di { clear AX }π mov cx, 8000h { set entire 64k memory area (all 4 pages) }π repnz stosw { to colour BLACK (ie, Clear screens) }π mov dx, 03d4h { User another VGA register }π mov al, 14h { Register = Underline Location }π out dx, alπ inc dx { Read status of register }π in al, dx { into AL }π and al, 0bFh { AND AL with 10111111b }π out dx, al { and send it to the register }π { to deactivate Double Word mode addressing }π dec dx { Okay, this time we want another register,}π mov al, 17h { Register = CRTC : Mode Control }π out dx, alπ inc dxπ in al, dx { Get status of this register }π or al, 40h { and Turn the 6th bit ON }π out dx, al { to turn WORD mode off }π { And thats all there is too it!}π End;πEnd;πππProcedure Flip;π{ This routine will flip to the next page, and change the value inπ PAGE such that we will allways be drawing to the invisible page. }πVarπ OfsAdr : Word;πBeginπ OfsAdr := Page * 16000;π asmπ mov dx, 03D4hπ mov al, 0Dh { Set the Start address LOW register }π out dx, alπ inc dxππ mov ax, OfsAdrπ out dx, al { by sending low byte of offset address }π dec dxπ mov al, 0Ch { now set the Start Address HIGH register }π out dx, alπ inc dxπ mov al, ahπ out dx, al { by sending high byte of offset address }π End;ππ Page := 1 - Page; { Flip the page value.π Effectively does a :π If Page = 0 then Page = 1 elseπ If Page = 1 then Page = 0. }πEnd;ππππProcedure PutPixel (X, Y : Integer; Colour : Byte );π{ Puts a pixel on the screen at the current page. }πVarπ OfsAdr : Word;πBEGINπ OfsAdr := Page * 16000;π ASMπ mov bx, xπ mov ax, Yπ mov cx, 80 { Since there are now 4 pixels per byte, weπ only multiply by 80 (320/4) }π mul cxπ mov di, axπ mov ax, bxπ shr ax, 1π shr ax, 1π add di, axπ and bx, 3π mov ah, 1π mov cl, blπ shl ah, clππ mov al, 2π mov dx, 03C4hππ mov bx, $A000π mov es, bxπ add di, OfsAdrππ out dx, ax { Set plane to address (where AH=Plane) }π mov al, Colourπ mov es:[di], alπ end;πend;ππBeginπ Randomize;π InitModeX;π Flip;ππ For I := 0 to 319 doπ For J := 0 to 199 doπ PutPixel(I, J, Random(32) );π Flip;ππ For I := 0 to 319 doπ For J := 0 to 199 doπ PutPixel(I, J, Random(32) + 32);ππ Repeatπ Flip;π Delay(200);π Until Keypressed;ππEnd.π 22 08-27-9321:52ALL MIKE BRENNAN Rotate Grahic Image IMPORT 17 ╓ {πMIKE BRENNANππ> I've been trying For some time to get a Pascal Procedure that canπ> SCALE and/or ROTATE Graphic images. if anyone has any idea how to doππ Here are a couple of Procedures I made For rotating images, 2D and 3D. Iπbasically had to rotate each dot individually, and then form the image byπconnecting the specified dots. Here they are...π}ππProcedure Rotate(cent1, cent2 : Integer; { Two centroids For rotation }π angle : Real; { Angle to rotate in degrees }π Var coord1, coord2 : Real); { both coordinates to rotate }πVarπ coord1t, coord2t : Real;πbeginπ {Set coordinates For temp system}π coord1t := coord1 - cent1;π coord2t := coord2 - cent2;ππ {set new rotated coordinates}π coord1 := coord1t * cos(angle * pi / 180) - coord2t * sin(angle * pi / 180);π coord2 := coord1t * sin(angle * pi / 180) + coord2t * cos(angle * pi / 180);ππ {Change coordinates from temp system}π coord1 := coord1 + cent1;π coord2 := coord2 + cent2;πend;ππProcedure Draw3d(x, y, z : Real; {coordinates} a, b : Real; {View angles}π Var newx, newy : Integer); {return coordinates}πVarπ Xd, Yd, Zd : Real;πbeginπ Xd := cos(a * pi / 180) * cos(b * pi / 180);π Yd := cos(b * pi / 180) * sin(a * pi / 180);π Zd := -sin(b * pi / 180);π {Set coordinates For X/Y system}π newx:= round(-z * Xd / Zd + x);π newy:= round(-z * Yd / Zd + y);πend;ππ{πFor the first Procedure, you can rotate an image along any two axes, (ieπX,Y...X,Z...Y,Z). Simply calculate the centroid For each axe, (the average Xπcoordinate, or Y or Z), then pass the angle to rotate (use a negative For otherπdirection) and it will pass back the new rotated coordinates.ππ The second Procedure is For 3D drawing only. It transforms any 3D dot intoπits corresponding position on a 2D plan (ie your screen). The new coordinatesπare returned in the NewX, and NewY. Those are what you would use to plot yourπdot on the screen.π} 23 08-27-9321:52ALL SEAN PALMER Another Graphic Rotate IMPORT 58 ╓ {πSEAN PALMERππ> I've been trying For some time to get a Pascal Procedure that canπ> SCALE and/or ROTATE Graphic images. if anyone has any idea how to do this,π> or has a source code, PLEEEAASSEE drop me a line.. THANK YOU!ππThis is an out-and-out blatant hack of the routines from Abrash'sπXSHARP21. They are too slow to be usable as implemented here.π}ππ{$A-,B-,D+,E-,F-,G+,I-,L+,N-,O-,R-,S-,V-,X+}π{$M $2000,0,0}πProgram VectTest;πUsesπ Crt, b320x200; {<-this Unit just implements Plot(x, y) and Color : Byte; }ππConstπ ClipMinY = 0;π ClipMaxY = 199;π ClipMinX = 0;π ClipMaxX = 319;π VertMax = 3;ππTypeπ fixed = Recordπ Case Byte ofπ 0 : (f : Byte; si : shortint);π 1 : (f2, b : Byte);π 2 : (w : Word);π 3 : (i : Integer);π end;ππ ByteArray = Array [0..63999] of Byte;ππ VertRec = Recordπ X, Y : Byte;π end;ππ VertArr = Array [0..VertMax] Of VertRec;π EdgeScan = Recordπ scansLeft : Integer;π Currentend : Integer;π srcX, srcY : fixed;π srcStepX,π srcStepY : fixed;π dstX : Integer;π dstXIntStep : Integer;π dstXdir : Integer;π dstXErrTerm : Integer;π dstXAdjUp : Integer;π dstXAdjDown : Integer;π dir : shortInt;π end;ππConstπ numVerts = 4;π mapX = 7;π mapY = 7;ππ Vertex : Array [0..vertMax] of vertRec =π ((x : 040; y : 020),π (x : 160; y : 050),π (x : 160; y : 149),π (x : 040; y : 179));ππ Points : Array [0..vertMax] of vertRec =π ((x : 0; y : 0),π (x : mapX; y : 0),π (x : mapX; y : mapY),π (x : 0; y : mapY));ππ texMap : Array [0..mapY, 0..mapX] of Byte =π (($F, $F, $F, $F, $F, $F, $F, $0),π ($F, $7, $7, $7, $7, $7, $F, $0),π ($F, $7, $2, $2, $2, $7, $F, $0),π ($F, $7, $2, $2, $2, $7, $F, $0),π ($F, $7, $2, $2, $9, $7, $F, $0),π ($F, $7, $2, $2, $2, $7, $F, $0),π ($F, $7, $2, $2, $2, $7, $F, $0),π ($0, $0, $0, $0, $0, $0, $0, $0));ππVarπ lfEdge,π rtEdge : EdgeScan;π z, z2 : Integer;ππFunction fixedDiv(d1, d2 : LongInt) : LongInt; Assembler;πAsmπ db $66; xor dx, dxπ mov cx, Word ptr D1+2π or cx, cxπ jns @Sπ db $66; dec dxπ @S:π mov dx, cxπ mov ax, Word ptr D1π db $66; shl ax, 16π db $66; idiv Word ptr d2π db $66; mov dx, axπ db $66; shr dx, 16πend;ππFunction div2Fixed(d1, d2 : LongInt) : LongInt; Assembler;πAsmπ db $66; xor dx, dxπ db $66; mov ax, Word ptr d1π db $66; shl ax, 16π jns @Sπ db $66; dec dxπ @S:π db $66; idiv Word ptr d2π db $66; mov dx, axπ db $66; shr dx, 16πend;ππFunction divfix(d1, d2 : Integer) : Integer; Assembler;πAsmπ mov al, Byte ptr d1+1π cbwπ mov dx, axπ xor al, alπ mov ah, Byte ptr d1π idiv d2πend;ππProcedure Draw;πVarπ MinY,π MaxY,π MinVert,π MaxVert,π I, dstY : Integer;ππ Function SetUpEdge(Var Edge : EdgeScan; StartVert : Integer) : Boolean;π Varπ NextVert : shortint;π dstXWidth : Integer;π T,π dstYHeight : fixed;π beginπ SetUpEdge := True;π While (StartVert <> MaxVert) Doπ beginπ NextVert := StartVert + Edge.dir;π if (NextVert >= NumVerts) Thenπ NextVert := 0π elseπ if (NextVert < 0) Thenπ NextVert := pred(NumVerts);ππ With Edge Doπ beginπ scansLeft := vertex[NextVert].Y - vertex[StartVert].Y;π if (scansLeft <> 0) Thenπ beginπ dstYHeight.f := 0;π dstYHeight.si := scansLeft;π Currentend := NextVert;π srcX.f := 0;π srcX.si := Points[StartVert].X;π srcY.f := 0;π srcY.si := Points[StartVert].Y;π srcStepX.i := divFix(points[nextVert].x - srcX.si, scansLeft);π srcStepY.i := divFix(points[nextVert].y - srcY.si, scansLeft);π dstX := vertex[StartVert].X;π dstXWidth := vertex[NextVert].X-vertex[StartVert].X;ππ if (dstXWidth < 0) Thenπ beginπ dstXdir := -1;π dstXWidth := -dstXWidth;π dstXErrTerm := 1 - scansLeft;π dstXIntStep := -(dstXWidth Div scansLeft);π endπ elseπ beginπ dstXdir := 1;π dstXErrTerm := 0;π dstXIntStep := dstXWidth Div scansLeft;π end;π dstXAdjUp := dstXWidth Mod scansLeft;π dstXAdjDown := scansLeft;π Exit;π end;π StartVert := NextVert;π end;π end;π SetUpEdge := False;π end;ππ Function StepEdge(Var Edge : EdgeScan) : Boolean;π beginπ Dec(Edge.scansLeft);π if (Edge.scansLeft = 0) Thenπ beginπ StepEdge := SetUpEdge(Edge, Edge.Currentend);π Exit;π end;π With Edge Doπ beginπ Inc(srcX.i, srcStepX.i);π Inc(srcY.i, srcStepY.i);π Inc(dstX, dstXIntStep);π Inc(dstXErrTerm, dstXAdjUp);π if (dstXErrTerm > 0) Thenπ beginπ Inc(dstX, dstXdir);π Dec(dstXErrTerm, dstXAdjDown);π end;π end;π StepEdge := True;π end;ππ Procedure ScanOutLine;π Varπ srcX,π srcY : fixed;π dstX,π dstXMax : Integer;π dstWidth,π srcXStep,π srcYStep : fixed;π beginπ srcX.w := lfEdge.srcX.w;π srcY.w := lfEdge.srcY.w;π dstX := lfEdge.dstX;π dstXMax := rtEdge.dstX;ππ if (dstXMax <= ClipMinX) Or (dstX >= ClipMaxX) Thenπ Exit;π dstWidth.f := 0;π dstWidth.si := dstXMax - dstX;π if (dstWidth.i <= 0) Thenπ Exit;π srcXStep.i := divFix(rtEdge.srcX.i - srcX.i, dstWidth.i);π srcYStep.i := divFix(rtEdge.srcY.i - srcY.i, dstWidth.i);π if (dstXMax > ClipMaxX) Thenπ dstXMax := ClipMaxX;π if (dstX < ClipMinX) Thenπ beginπ Inc(srcX.i, srcXStep.i * (ClipMinX - dstX));π Inc(srcY.i, srcYStep.i * (ClipMinX - dstX));π dstX := ClipMinX;π end;ππ Asmπ mov ax, $A000π mov es, axπ mov ax, xResπ mul dstYπ add ax, dstXπ mov di, axπ mov cx, dstXMaxπ sub cx, dstXπ mov bx, srcXStep.iπ mov dx, srcYStep.iπ @L:π mov al, srcY.&siπ xor ah, ahπ shl ax, 3π add al, srcX.&siπ add ax, offset texmapπ mov si, axπ movsbπ add srcX.i,bxπ add srcY.i,dxπ loop @Lπ end;π end;ππbeginπ if (NumVerts < 3) Thenπ Exit;π MinY := vertex[numVerts - 1].y;π maxY := vertex[numVerts - 1].y;π maxVert := numVerts - 1;π minVert := numVerts - 1;π For I := numVerts - 2 downto 0 Doπ beginπ if (vertex[I].Y < MinY) Thenπ beginπ MinY := vertex[I].Y;π MinVert := I;π end;π if (vertex[I].Y > MaxY) Thenπ beginπ MaxY := vertex[I].Y;π MaxVert := I;π end;π end;π if (MinY >= MaxY) Thenπ Exit;π dstY := MinY;π lfEdge.dir := -1;π SetUpEdge(lfEdge, MinVert);π rtEdge.dir := 1;π SetUpEdge(rtEdge, MinVert);π While (dstY < ClipMaxY) Doπ beginπ if (dstY >= ClipMinY) Thenπ ScanOutLine;π if Not StepEdge(lfEdge) Thenπ Exit;π if Not StepEdge(rtEdge) Thenπ Exit;π Inc(dstY);π end;πend;ππbeginπ directVideo := False;π TextAttr := 63;π { For z:=0 to mapY do For z2:=0 to mapx do texMap[z,z2]:=random(6+53);}π For z := 4 to 38 doπ beginπ clearGraph;π vertex[0].x := z * 4;π vertex[3].x := z * 4;π draw;π if KeyPressed thenπ beginπ ReadKey;π ReadKey;π end;π end;π readln;πend.ππ 24 08-27-9321:52ALL WILLIAM SITCH Rotate PIC IMPORT 22 ╓ {πWILLIAM SITCHππ> I've been trying For some time to get a Pascalπ> Procedure that can SCALE and/or ROTATE Graphic images. ifπ> anyone has any idea how to do this, or has a source code,π> PLEEEAASSEE drop me a line.. THANK YOU!ππHere is some code to rotate an image (in MCGA screen mode $13) ... but it has aπfew drawbacks... its kinda slow and the image falls apart during rotation... itπhasn't been tested fully either...π}ππProcedure rotate(x1, y1, x2, y2 : Word; ang, ainc : Real);πVarπ ca, sa : Real;π cx, cy : Real;π dx, dy : Real;π h, i,π j, k : Word;ππ pinf : Array [1..12500] of Recordπ x, y : Word;π col : Byte;π end;ππbeginπ ca := cos((ainc / 180) * pi);π sa := sin((ainc / 180) * pi);ππ For h := 1 to round(ang / ainc) doπ beginπ k := 0;π cx := x1 + ((x2 - x1) / 2);π cy := y1 + ((y2 - y1) / 2);π For i := x1 to x2 doπ For j := y1 to y2 doπ beginπ inc(k);ππ dx := cx + (((i - cx) * ca) - ((j - cy) * sa));π dy := cy + (((i - cx) * sa) + ((j - cy) * ca));ππ if (round(dx) > 0) and (round(dy) > 0) andπ (round(dx) < 65000) and (round(dy) < 65000) thenπ beginπ pinf[k].x := round(dx);π pinf[k].y := round(dy);π pinf[k].col := mem[$A000 : j * 320 + i];π endπ elseπ beginπ pinf[k].x := 0;π pinf[k].y := 0;π pinf[k].col := 0;π end;π end;ππ For i := x1 to x2 doπ For j := y1 to y2 doπ mem[$A000 : j * 320 + i] := 0;ππ x1 := 320;π x2 := 1;π y1 := 200;π y2 := 1;π For i := 1 to k doπ beginπ if (pinf[i].x < x1) thenπ x1 := pinf[i].x;π if (pinf[i].x > x2) thenπ x2 := pinf[i].x;ππ if (pinf[i].y < y1) thenπ y1 := pinf[i].y;π if (pinf[i].y > y2) thenπ y2 := pinf[i].y;ππ if (pinf[i].x > 0) and (pinf[i].y > 0) thenπ mem[$A000 : pinf[i].y * 320 + pinf[i].x] := pinf[i].col;π end;π end;πend;ππ{πIt works, but DON'T try to use it For a main module or base a Program AROUNDπit... instead try to change it to suit your needs, as right now it's kindaπoptimized For my needs...ππSorry For not editing it to work With any screen mode, but I just don't haveπthe time. MCGA memory is a linear block of Bytes, and you can access it using:πmem[$A000:offset]. So to find the color at screen position 10,10, you wouldπgo:ππmem[$A000 : y * 320 + x]π ^ ^ ^-- x val, 10π | |----- screenwidthπ |-------- y val, 10π} 25 08-27-9321:58ALL WILLIAM SITCH Graphic Spinning Disk IMPORT 24 ╓ {πWILLIAM SITCHππ> Okay, I've just finally got my hands on the formulas forπ> doing good Graphics manipulations...well, I decided to startπ> With something simple. A rotating square. But it DOESN'Tπ> WORK RIGHT. I noticed the size seemed to shift in and outπ> and a little testing showed me that instead of following aπ> circular path (as they SHOULD), the corners (while spinning)π> actually trace out an OCTAGON. Why???? I've checked andπ> rechecked the formula logic...It's just as I was given. Soπ> there's some quirk about the code that I don't know about.π> Here's the rotating routine:ππAhhh... "rounding errors" is what my comp sci teacher explained to me, butπthere isn't much you can do about it... I've included my (rather long)πspinning disc code to take a look at ... feel free to try to port it to yourπapplication...ππ}ππUsesπ Graph, Crt;ππProcedure spin_disk;πTypeπ pointdataType = Array [1..4] of Record x,y : Integer; end;πConstπ delVar = 10;ππVarπ ch : Char;π p, op : pointdataType;π cx, cy,π x, y, r : Integer;π i : Integer;π rot : Integer;π tempx,π tempy : Integer;π theta : Real;π down : Boolean;π del : Real;πbeginπ cx := getmaxx div 2;π cy := getmaxy div 2;π r := 150;π circle(cx,cy,r);ππ rot := 0;π p[1].x := 100; p[1].y := 0;π p[2].x := 0; p[2].y := -100;π p[3].x := -100; p[3].y := 0;π p[4].x := 0; p[4].y := 100;π del := 50;π down := True;ππ Repeatπ rot := rot + 2;π theta := rot * 3.14 / 180;π For i := 1 to 4 doπ beginπ tempx := p[i].x;π tempy := p[i].y;π op[i].x := p[i].x;π op[i].y := p[i].y;π p[i].x := round(cos(theta) * tempx - sin(theta) * tempy);π p[i].y := round(sin(theta) * tempx + cos(theta) * tempy);π end;π setcolor(0);π line(op[1].x + cx,cy - op[1].y,op[2].x + cx,cy - op[2].y);π line(op[2].x + cx,cy - op[2].y,op[3].x + cx,cy - op[3].y);π line(op[3].x + cx,cy - op[3].y,op[4].x + cx,cy - op[4].y);π line(op[4].x + cx,cy - op[4].y,op[1].x + cx,cy - op[1].y);π For i := 1 to 4 doπ line(op[i].x + cx,cy - op[i].y,cx,cy);π setcolor(11);π line(p[1].x + cx,cy - p[1].y,p[2].x + cx,cy - p[2].y);π line(p[2].x + cx,cy - p[2].y,p[3].x + cx,cy - p[3].y);π line(p[3].x + cx,cy - p[3].y,p[4].x + cx,cy - p[4].y);π line(p[4].x + cx,cy - p[4].y,p[1].x + cx,cy - p[1].y);π setcolor(10);π For i := 1 to 4 doπ line(p[i].x + cx,cy - p[i].y,cx,cy);π if (del < 1) thenπ down := Falseπ else if (del > 50) thenπ down := True;π if (down) thenπ del := del - delVarπ elseπ del := del + delVar;π Delay(round(del));π Until (KeyPressed = True);π ch := ReadKey;π NoSound;πend;ππVarπ Gd, Gm : Integer;ππbeginπ Gd := Detect;π InitGraph(Gd, Gm, 'd:\bp\bgi');ππ Spin_disk;ππend. 26 08-27-9321:59ALL SEAN PALMER Drawing a B-Spline curve IMPORT 22 ╓ {πSEAN PALMERππI was just toying around With a B-Spline curve routine I got out of anπold issue of Byte, and thought it was pretty neat. I changed it to useπfixed point fractions instead of Reals, and optimized it some...ππby Sean Palmerπpublic domainπ}ππVarπ color : Byte;πProcedure plot(x, y : Word);πbeginπ mem[$A000 : y * 320 + x] := color;πend;ππTypeπ coord = Recordπ x, y : Word;π end;ππ CurveDataRec = Array [0..65521 div sizeof(coord)] of coord;ππFunction fracMul(f, f2 : Word) : Word;πInline(π $58/ {pop ax}π $5B/ {pop bx}π $F7/$E3/ {mul bx}π $89/$D0); {mov ax,dx}ππFunction mul(f, f2 : Word) : LongInt;πInline(π $58/ {pop ax}π $5B/ {pop bx}π $F7/$E3); {mul bx}πππConstπ nSteps = 1 shl 8; {about 8 For smoothness (dots), 4 For speed (lines)}ππProcedure drawBSpline(Var d0 : coord; nPoints : Word);πConstπ nsa = $10000 div 6;π nsb = $20000 div 3;π step = $10000 div nSteps;πVarπ i, xx, yy,π t1, t2, t3,π c1, c2, c3, c4 : Word;ππ d : curveDataRec Absolute d0;ππbeginπ t1 := 0;π color := 32 + 2;ππ For i := 0 to nPoints - 4 doπ beginππ {algorithm converted from Steve Enns' original Basic subroutine}ππ Repeatπ t2 := fracMul(t1, t1);π t3 := fracMul(t2, t1);π c1 := (Integer(t2 - t1) div 2) + nsa - fracmul(nsa, t3);π c2 := (t3 shr 1) + nsb - t2;π c3 := ((t2 + t1 - t3) shr 1) + nsa;π c4 := fracmul(nsa, t3);π xx := (mul(c1, d[i].x) + mul(c2, d[i + 1].x) +π mul(c3, d[i + 2].x) + mul(c4, d[i + 3].x)) shr 16;π yy := (mul(c1, d[i].y) + mul(c2, d[i + 1].y) +π mul(c3, d[i + 2].y) + mul(c4, d[i + 3].y)) shr 16;π plot(xx, yy);π inc(t1, step);π Until t1 = 0; {this is why nSteps must be even power of 2}π inc(color);π end;πend;ππConstπ pts = 24; {number of points} {chose this because of colors}ππVarπ c : Array [-1..2 + pts] of coord;π i : Integer;πbeginπ Asmπ mov ax, $13π int $10π end; {init vga/mcga Graphics}π randomize;π For i := 1 to pts doπ With c[i] doπ beginπ {x:=i*(319 div pts);} {for precision demo}π x := random(320); {for fun demo}π y := random(200);π end;π {for i:=1 to pts div 2 do c[i*2+1].y:=c[i*2].y;} {fit closer}π For i := 1 to pts doπ With c[i] doπ beginπ color := i + 32;π plot(x, y);π end;π {replicate end points so curves fit to input}π c[-1] := c[1];π c[0] := c[1];π c[pts + 1] := c[pts];π c[pts + 2] := c[pts];π drawBSpline(c[-1], pts + 4);π readln;π Asmπ mov ax, 3π int $10π end; {Text mode again}πend.π 27 08-27-9321:59ALL SEAN PALMER Another B-Spline Curve IMPORT 35 ╓ {πSEAN PALMERππI've been playing around with it as a way to make 'heat-seekingπmissiles' in games. Very interesting...ππWhat I do is have the points set up as follows:ππ1 : current positionπ2&3 : current speed + the current positionπ4 : destinationππand update current position by indexing somewhere into the curve (likeπat $100 out of $FFFFππThis works very well. Problem is that I don't know of a good way toπchange the speed.ππHere is a simple demo that makes a dot chase the mouse cursor (needsπVGA as written) that shows what I mean.ππIf ANYBODY can make this work smoother or improve on it in any way Iπwould appreciate being told how... 8)π}ππusesπ mouse, crt; { you will need to change accesses to the mouse unit }π { to use a mouse package that you provide }πtypeπ coord = recordπ x, y : word;π end;π CurveDataRec = array [0..65521 div sizeof(coord)] of coord;ππconstπ nSteps = 1 shl 8; {about 8 for smoothness (dots), 4 for speed (lines)}ππvarπ color : byte;π src, spd,π dst, mov1,π mov2 : coord;π i : integer;ππprocedure plot(x, y : word);πbeginπ mem[$A000 : y * 320 + x] := color;πend;ππfunction fracMul(f, f2 : word) : word;πInline(π $58/ {pop ax}π $5B/ {pop bx}π $F7/$E3/ {mul bx}π $89/$D0); {mov ax,dx}ππfunction mul(f, f2 : word) : longint;πinline(π $58/ {pop ax}π $5B/ {pop bx}π $F7/$E3); {mul bx}πππ{this is the original full BSpline routine}ππprocedure drawBSpline(var d0 : coord; nPoints : word);πconstπ nsa = $10000 div 6;π nsb = $20000 div 3;π step = $10000 div nSteps;πvarπ i, xx, yy : word;π t1, t2, t3 : word;π c1, c2, c3, c4 : word;π d : curveDataRec absolute d0;πbeginπ t1 := 0;π color := 32 + 2;π for i := 0 to nPoints - 4 doπ beginπ {algorithm converted from Steve Enns' original Basic subroutine}π repeatπ t2 := fracMul(t1, t1);π t3 := fracMul(t2, t1);π c1 := (integer(t2 - t1) div 2) + nsa - fracmul(nsa, t3);π c2 := (t3 shr 1) + nsb - t2;π c3 := ((t2 + t1 - t3) shr 1) + nsa;π c4 := fracmul(nsa, t3);π xx := (mul(c1, d[i].x) + mul(c2, d[i + 1].x) +π mul(c3, d[i + 2].x) + mul(c4, d[i + 3].x)) shr 16;π yy := (mul(c1, d[i].y) + mul(c2, d[i + 1].y) +π mul(c3, d[i + 2].y) + mul(c4, d[i + 3].y)) shr 16;π plot(xx, yy);π inc(t1, step);π until t1 = 0; {this is why nSteps must be even power of 2}π inc(color);π end;πend;πππ{find 1/nth point in BSpline} {this is what does the B-Spline work}ππprocedure moveTowards(d1, d2, d3, d4 : coord; t1 : word; var mov : coord);πconstπ nsa = $10000 div 6;π nsb = $20000 div 3;πvarπ t2, t3 : word;π c1, c2,π c3, c4 : word;πbeginπ t2 := fracMul(t1, t1);π t3 := fracMul(t2, t1);π c1 := (integer(t2 - t1) div 2) + nsa - fracmul(nsa, t3);π c2 := (t3 shr 1) + nsb - t2;π c3 := ((t2 + t1 - t3) shr 1) + nsa;π c4 := fracmul(nsa, t3);π mov.x := (mul(c1, d1.x) + mul(c2, d2.x) + mul(c3, d3.x) + mul(c4, d4.x)) shr 16;π mov.y := (mul(c1, d1.y) + mul(c2, d2.y) + mul(c3, d3.y) + mul(c4, d4.y)) shr 16;πend;ππbeginπ asmπ mov ax, $13π int $10π end; {init vga/mcga graphics}ππ {mouse.init;}π mshow;ππ src.x := 5;π src.y := 5;π spd.x := 5;π spd.y := 5;π dst.x := 315;π dst.y := 190;ππ repeatπ {for i:=0 to 23 do begin}π { color:=i+32;}π { inc(dst.x,i);}π delay(10);π {mouse.check;} {this loads Mouse.X, Mouse.Y, Mouse.Button from driver}π mhide;π color := 15;π plot(src.x, src.y);π color := 14;π plot(spd.x, spd.y);π dst.x := mousex shr 1;π dst.y := mousey;π color := 1;π plot(dst.x, dst.y);π mshow;ππ {the parameters in these next two lines can be changed}π {I have played with almost all possible combinations and}π {most work, but not well, so don't be afraid to play around}π {But I think an entirely different approach is needed for the}π {second moveTowards..}ππ moveTowards(src, src, spd, dst, $0010, mov1);π moveTowards(src, spd, dst, dst, $5000, mov2);π src := mov1;π longint(spd) := (longint(spd) * 7 + longint(mov2)) shr 3 and $1FFF1FFF;π until 1=0;ππ mhide;ππ asmπ mov ax, 3π int $10π end; {text mode again}πend.ππ 28 08-27-9322:00ALL BRENDEN BEAMAN Another Star field IMPORT 14 ╓ { BRendEN BEAMAN }ππProgram starfield;πUsesπ Crt, Graph;ππVarπ l, l2,π gd, gm,π x, y : Integer;π rad : Array [1..20] of Integer;π p : Array [1..20, 1..5] of Integer;ππProcedure put(p, rad : Integer; col : Word);πbeginπ setcolor(col); {1 pixel arc instead of putpixel}π arc(x, y, p, p + 1, rad);πend;ππProcedure putstar;πbeginπ For l := 1 to 20 do {putting stars. #15 below is color of stars}π For l2 := 1 to 5 do put(p[l, l2], rad[l], 15);πend;ππProcedure delstar;πbeginπ For l := 1 to 20 do {erasing stars}π For l2 := 1 to 5 do put(p[l, l2], rad[l], 0);πend;ππbeginπ randomize;π gd := detect;π initGraph(gd, gm, 'd:\bp\bgi');π x := 320;π y := 240;ππ For l := 1 to 20 doπ rad[l] := l * 10;π For l := 1 to 20 doπ For l2 := 1 to 5 doπ p[l, l2] := random(360);ππ While not KeyPressed doπ beginπ delstar;π For l := 1 to 20 doπ begin {moving stars towards 'camera'}π rad[l] := rad[l] + round(rad[l] / 20 + 1); { (20)=starspeed. }π if rad[l] > 400 thenπ rad[l] := l * 10; { starspeed must be equal }π end; { to or less than 20 }π putstar;π end;π readln;πend.ππ The concept is fairly simple, but most people underestimate arcs...π you can set where on the circle, (0-360 degres) the arc starts, andπ stops... if you set a one pixel arc at 100, and increase the radius ofπ the circle in a loop, it will apear to come towards you in threeπ dimentions... any other questions, or problems running it, contactπ me... ttylπ 29 08-27-9322:08ALL SEAN PALMER TWEAKED! Graph unit IMPORT 132 ╓ {$A-,B-,D+,E-,F-,G+,I-,L+,N-,O-,R-,S-,V-,X+} {TP 6.0 & 286 required!}πUnit x320x240;ππ{π Sean Palmer, 1993π released to the Public Domainπ in tweaked modes, each latch/bit plane contains the entire 8-bit pixel.π the sequencer map mask determines which plane (pixel) to update, and, whenπ reading, the read map select reg determines which plane (pixel) to read.π almost exactly opposite from regular vga 16-color modes which is why I neverπ could get my routines to work For BOTH modes. 8)ππ # = source screen pixelπ Normal 16-color Tweaked 256-colorππ Bit Mask Bit Maskπ 76543210 33333333π Map 76543210 Map 22222222π Mask 76543210 Mask 11111111π 76543210 00000000ππ Functional equivalentsπ Bit Mask = Seq Map Maskπ Seq Map Mask = Bit Maskπ}πππInterfaceππVarπ color : Byte;ππConstπ xRes = 320;π yRes = 240; {displayed screen size}π xMax = xRes - 1;π yMax = yRes - 1;π xMid = xMax div 2;π yMid = yMax div 2;π vxRes = 512;π vyRes = $40000 div vxRes; {virtual screen size}π nColors = 256;π tsx : Byte = 8;π tsy : Byte = 8; {tile size}πππProcedure plot(x, y : Integer);πFunction scrn(x, y : Integer) : Byte;ππProcedure hLin(x, x2, y : Integer);πProcedure vLin(x, y, y2 : Integer);πProcedure rect(x, y, x2, y2 : Integer);πProcedure pane(x, y, x2, y2 : Integer);ππProcedure line(x, y, x2, y2 : Integer);πProcedure oval(xc, yc, a, b : Integer);πProcedure disk(xc, yc, a, b : Integer);πProcedure fill(x, y : Integer);ππProcedure putTile(x, y : Integer; p : Pointer);πProcedure overTile(x, y : Integer; p : Pointer);πProcedure putChar(x, y : Integer; p : Word);ππProcedure setColor(color, r, g, b : Byte);π{rgb vals are from 0-63}πFunction getColor(color : Byte) : LongInt;π{returns $00rrggbb format}πProcedure setPalette(color : Byte; num : Word; Var rgb);π{rgb is list of 3-Byte rgb vals}πProcedure getPalette(color : Byte; num : Word; Var rgb);ππProcedure clearGraph;πProcedure setWriteMode(f : Byte);πProcedure waitRetrace;πProcedure setWindow(x, y : Integer);ππ{XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX}ππImplementationππConstπ vSeg = $A000; {video segment}π vxBytes = vxRes div 4; {Bytes per virtual scan line}π seqPort = $3C4; {Sequencer}π gcPort = $3CE; {Graphics Controller}π attrPort = $3C0; {attribute Controller}ππ tableReadIndex = $3C7;π tableWriteIndex = $3C8;π tableDataRegister = $3C9;ππ CrtcRegLen = 10;π CrtcRegTable : Array [1..CrtcRegLen] of Word =π ($0D06, $3E07, $4109, $EA10, $AC11, $DF12, $0014, $E715, $0616, $E317);ππππVarπ CrtcPort : Word; {Crt controller}π oldMode : Byte;π ExitSave : Pointer;π input1Port : Word; {Crtc Input Status Reg #1=CrtcPort+6}π fillVal : Byte;ππTypeπ tRGB = Recordπ r, g, b : Byte;π end;ππ{XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX}ππProcedure clearGraph; Assembler;πAsmπ mov ax, vSegπ mov es, axπ mov dx, seqPortπ mov ax, $0F02π out dx, ax {enable whole map mask}π xor di, diπ mov cx, $8000 {screen size in Words}π cldπ mov al, colorπ mov ah, alπ repz stosw {clear screen}πend;ππProcedure setWriteMode(f : Byte); Assembler;πAsm {copy/and/or/xor modes}π mov ah, fπ shl ah, 3π mov al, 3π mov dx, gcPortπ out dx, ax {Function select reg}πend;ππProcedure waitRetrace; Assembler;πAsmπ mov dx, CrtcPortπ add dx, 6 {find Crt status reg (input port #1)}π @L1:π in al, dxπ test al, 8π jnz @L1; {wait For no v retrace}π @L2:π in al, dxπ test al, 8π jz @L2 {wait For v retrace}π end;πππ{π Since a virtual screen can be larger than the actual screen, scrolling isπ possible. This routine sets the upper left corner of the screen to theπ specified pixel. Make sure 0 <= x <= vxRes - xRes, 0 <= y <= vyRes - yResπ}πProcedure setWindow(x, y : Integer); Assembler;πAsmπ mov ax, vxBytesπ mul yπ mov bx, xπ mov cl, blπ shr bx, 2π add bx, ax {bx=Ofs of upper left corner}π mov dx, input1Portπ @L:π in al, dxπ test al, 8π jnz @L {wait For no v retrace}π sub dx, 6 {CrtC port}π mov al, $Dπ mov ah, blπ cli {these values are sampled at start of retrace}π out dx, ax {lo Byte of display start addr}π dec alπ mov ah, bhπ out dx, ax {hi Byte}π stiπ add dx, 6π @L2:π in al, dxπ test al, 8π jz @L2 {wait For v retrace}π {this also resets Attrib flip/flop}π mov dx, attrPortπ mov al, $33π out dx, al {Select Pixel Pan Register}π and cl, 3π mov al, clπ shl al, 1π out dx, al {Shift is For 256 Color Mode}πend;ππ{XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX}ππProcedure plot(x, y : Integer); Assembler;πAsmπ mov ax, vSegπ mov es, axπ mov di, xπ mov cx, diπ shr di, 2π mov ax, vxBytesπ mul yπ add di, axπ mov ax, $0102π and cl, 3π shl ah, clπ mov dx, seqPortπ out dx, ax {set bit mask}π mov al, colorπ stosbπend;ππFunction scrn(x, y : Integer) : Byte; Assembler;πAsmπ mov ax, vSegπ mov es, axπ mov di, xπ mov cx, diπ shr di, 2π mov ax, vxBytesπ mul yπ add di, axπ and cl, 3π mov ah, clπ mov al, 4π mov dx, gcPortπ out dx, ax {Read Map Select register}π mov al, es:[di] {get the whole plane}πend;ππProcedure hLin(x, x2, y : Integer); Assembler;πAsmπ mov ax, vSegπ mov es, axπ cldπ mov ax, vxBytesπ mul yπ mov di, ax {base of scan line}π mov bx, xπ mov cl, blπ shr bx, 2π mov dx, x2π mov ch, dlπ shr dx, 2π and cx, $0303π sub dx, bx {width in Bytes}π add di, bx {offset into video buffer}π mov ax, $FF02π shl ah, clπ and ah, $0F {left edge mask}π mov cl, chπ mov bh, $F1π rol bh, clπ and bh, $0F {right edge mask}π mov cx, dxπ or cx, cxπ jnz @LEFTπ and ah, bh {combine left & right bitmasks}π @LEFT:π mov dx, seqPortπ out dx, axπ inc dxπ mov al, colorπ stosbπ jcxz @EXITπ dec cxπ jcxz @RIGHTπ mov al, $0Fπ out dx, al {skipped if cx=0,1}π mov al, colorπ repz stosb {fill middle Bytes}π @RIGHT:π mov al, bhπ out dx, al {skipped if cx=0}π mov al, colorπ stosbπ @EXIT:πend;ππProcedure vLin(x, y, y2 : Integer); Assembler;πAsmπ mov ax, vSegπ mov es, axπ cldπ mov di, xπ mov cx, diπ shr di, 2π mov ax, vxBytesπ mul yπ add di, axπ mov ax, $102π and cl, 3π shl ah, clπ mov dx, seqPortπ out dx, axπ mov cx, y2π sub cx, yπ inc cxπ mov al, colorπ @DOLINE:π mov bl, es:[di]π stosbπ add di, vxBytes-1π loop @DOLINEπend;ππProcedure rect(x, y, x2, y2 : Integer);πVarπ i : Word;πbeginπ hlin(x, pred(x2), y);π hlin(succ(x), x2, y2);π vlin(x, succ(y), y2);π vlin(x2, y, pred(y2));πend;ππProcedure pane(x, y, x2, y2 : Integer);πVarπ i : Word;πbeginπ For i := y2 downto y doπ hlin(x, x2, i);πend;ππProcedure line(x, y, x2, y2:Integer);πVarπ d, dx, dy,π ai, bi, xi, yi : Integer;πbeginπ if(x < x2) thenπ beginπ xi := 1;π dx := x2 - x;π endπ elseπ beginπ xi := -1;π dx := x - x2;π end;π if (y < y2) thenπ beginπ yi := 1;π dy := y2 - y;π endπ elseπ beginπ yi := -1;π dy := y - y2;π end;π plot(x, y);π if dx > dy thenπ beginπ ai := (dy - dx) * 2;π bi := dy * 2;π d := bi - dx;π Repeatπ if (d >= 0) thenπ beginπ inc(y, yi);π inc(d, ai);π endπ elseπ inc(d, bi);π inc(x, xi);π plot(x, y);π Until (x = x2);π endπ elseπ beginπ ai := (dx - dy) * 2;π bi := dx * 2;π d := bi - dy;π Repeatπ if (d >= 0) thenπ beginπ inc(x, xi);π inc(d, ai);π endπ elseπ inc(d, bi);π inc(y, yi);π plot(x, y);π Until (y = y2);π end;πend;ππProcedure oval(xc, yc, a, b : Integer);πVarπ x, y : Integer;π aa, aa2,π bb, bb2,π d, dx, dy : LongInt;πbeginπ x := 0;π y := b;π aa := LongInt(a) * a;π aa2 := 2 * aa;π bb := LongInt(b) * b;π bb2 := 2 * bb;π d := bb - aa * b + aa div 4;π dx := 0;π dy := aa2 * b;π plot(xc, yc - y);π plot(xc, yc + y);π plot(xc - a, yc);π plot(xc + a, yc);π While (dx < dy) doπ beginπ if(d > 0) thenπ beginπ dec(y);π dec(dy, aa2);π dec(d, dy);π end;π inc(x);π inc(dx, bb2);π inc(d, bb + dx);π plot(xc + x, yc + y);π plot(xc - x, yc + y);π plot(xc + x, yc - y);π plot(xc - x, yc - y);π end;ππ inc(d, (3 * (aa - bb) div 2 - (dx + dy)) div 2);ππ While (y > 0) doπ beginπ if (d < 0) thenπ beginπ inc(x);π inc(dx, bb2);π inc(d, bb + dx);π end;π dec(y);π dec(dy, aa2);π inc(d, aa - dy);π plot(xc + x, yc + y);π plot(xc - x, yc + y);π plot(xc + x, yc - y);π plot(xc - x, yc - y);π end;πend;ππProcedure disk(xc, yc, a, b:Integer);πVarπ x, y : Integer;π aa, aa2,π bb, bb2,π d, dx, dy : LongInt;πbeginπ x := 0;π y := b;π aa := LongInt(a) * a;π aa2 := 2 * aa;π bb := LongInt(b) * b;π bb2 := 2 * bb;π d := bb - aa * b + aa div 4;π dx := 0;π dy := aa2 * b;ππ vLin(xc, yc - y, yc + y);ππ While (dx < dy) doπ beginπ if (d > 0) thenπ beginπ dec(y);π dec(dy, aa2);π dec(d, dy);π end;π inc(x);π inc(dx, bb2);π inc(d, bb + dx);π vLin(xc - x, yc - y, yc + y);π vLin(xc + x, yc - y, yc + y);π end;ππ inc(d, (3 * (aa - bb) div 2 - (dx + dy)) div 2);ππ While (y >= 0) doπ beginπ if (d < 0) thenπ beginπ inc(x);π inc(dx, bb2);π inc(d, bb + dx);π vLin(xc - x, yc - y, yc + y);π vLin(xc + x, yc - y, yc + y);π end;π dec(y);π dec(dy, aa2);π inc(d, aa - dy);π end;πend;ππ{This routine only called by fill}πFunction lineFill(x, y, d, prevXL, prevXR : Integer) : Integer;πVarπ xl, xr, i : Integer;πLabelπ _1, _2, _3;πbeginπ xl := x;π xr := x;ππ Repeatπ dec(xl);π Until (scrn(xl, y) <> fillVal) or (xl < 0);ππ inc(xl);ππ Repeatπ inc(xr);π Until (scrn(xr, y) <> fillVal) or (xr > xMax);ππ dec(xr);π hLin(xl, xr, y);π inc(y, d);ππ if Word(y) <= yMax thenπ For x := xl to xr doπ if (scrn(x, y) = fillVal) thenπ beginπ x := lineFill(x, y, d, xl, xr);π if Word(x) > xr thenπ Goto _1;π end;ππ _1 :ππ dec(y, d + d);π Asmπ neg d;π end;π if Word(y) <= yMax thenπ beginπ For x := xl to prevXL doπ if (scrn(x, y) = fillVal) thenπ beginπ i := lineFill(x, y, d, xl, xr);π if Word(x) > prevXL thenπ Goto _2;π end;ππ _2 :ππ for x := prevXR to xr doπ if (scrn(x, y) = fillVal) thenπ beginπ i := lineFill(x, y, d, xl, xr);π if Word(x) > xr thenπ Goto _3;π end;ππ _3 :ππ end;ππ lineFill := xr;πend;ππProcedure fill(x, y : Integer);πbeginπ fillVal := scrn(x, y);π if fillVal <> color thenπ lineFill(x, y, 1, x, x);πend;πππ{XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX}ππProcedure putTile(x, y : Integer; p : Pointer); Assembler;πAsmπ push dsπ lds si, pπ mov ax, vSegπ mov es, axπ mov di, xπ mov cx, diπ shr di, 2π mov ax, vxBytesπ mul yπ add di, axπ mov ax, $102π and cl, 3π shl ah, cl {make bit mask}π mov dx, seqPortπ mov bh, tsyπ @DOLINE:π mov cl, tsxπ xor ch, chπ push axπ push di {save starting bit mask}π @LOOP:π {mov al, 2}π out dx, axπ shl ah, 1 {give it some time to respond}π mov bl, es:[di]π movsbπ dec diπ test ah, $10π jz @SAMEByteπ mov ah, 1π inc diπ @SAMEByte:π loop @LOOPπ pop diπ add di, vxBytesπ pop ax {start of next line}π dec bhπ jnz @DOLINEπ pop dsπend;ππProcedure overTile(x, y : Integer; p : Pointer); Assembler;πAsmπ push dsπ lds si, pπ mov ax, vSegπ mov es, axπ mov di, xπ mov cx, diπ shr di, 2π mov ax, vxBytesπ mul yπ add di, axπ mov ax, $102π and cl, 3π shl ah, cl {make bit mask}π mov bh, tsyπ mov dx, seqPortπ @DOLINE:π mov ch, tsxπ push axπ push di {save starting bit mask}π @LOOP:π mov al, 2π mov dx, seqPortπ out dx, axπ shl ah, 1π xchg ah, clπ mov al, 4π mov dl, gcPort and $FFπ out dx, axπ xchg ah, clπ inc clπ and cl, 3π lodsbπ or al, alπ jz @SKIPπ mov bl, es:[di]π cmp bl, $C0π jae @SKIPπ stosbπ dec diπ @SKIP:π test ah, $10π jz @SAMEByteπ mov ah, 1π inc diπ @SAMEByte:π dec chπ jnz @LOOPπ pop diπ add di, vxBytesπ pop ax {start of next line}π dec bhπ jnz @DOLINEπ pop dsπend;ππ{won't handle Chars wider than 1 Byte}πProcedure putChar(x, y : Integer; p : Word); Assembler;πAsmπ mov si, p {offset of Char in DS}π mov ax, vSegπ mov es, axπ mov di, xπ mov cx, diπ shr di, 2π mov ax, vxBytesπ mul yπ add di, axπ mov ax, $0102π and cl, 3π shl ah, cl {make bit mask}π mov dx, seqPortπ mov cl, tsyπ xor ch, chπ @DOLINE:π mov bl, [si]π inc siπ push axπ push di {save starting bit mask}π @LOOP:π mov al, 2π out dx, axπ shl ah, 1π shl bl, 1π jnc @SKIPπ mov al, colorπ mov es:[di], alπ @SKIP:π test ah, $10π jz @SAMEByteπ mov ah, 1π inc diπ @SAMEByte:π or bl, blπ jnz @LOOPπ pop diπ add di, vxBytesπ pop ax {start of next line}π loop @DOLINEπend;ππ{XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX}ππProcedure setColor(color, r, g, b : Byte); Assembler;πAsm {set DAC color}π mov dx, tableWriteIndexπ mov al, colorπ out dx, alπ inc dxπ mov al, rπ out dx, alπ mov al, gπ out dx, alπ mov al, bπ out dx, alπend; {Write index now points to next color}ππFunction getColor(color : Byte) : LongInt; Assembler;πAsm {get DAC color}π mov dx, tableReadIndexπ mov al, colorπ out dx, alπ add dx, 2π cldπ xor bh, bhπ in al, dxπ mov bl, alπ in al, dxπ mov ah, alπ in al, dxπ mov dx, bxπend; {read index now points to next color}ππProcedure setPalette(color : Byte; num : Word; Var rgb); Assembler;πAsmπ mov cx, numπ jcxz @Xπ mov ax, cxπ shl cx, 1π add cx, ax {mul by 3}π push dsπ lds si, rgbπ cldπ mov dx, tableWriteIndexπ mov al, colorπ out dx, alπ inc dxπ @L:π lodsbπ out dx, alπ loop @Lπ pop dsπ @X:πend;ππProcedure getPalette(color : Byte; num : Word; Var rgb); Assembler;πAsmπ mov cx, numπ jcxz @Xπ mov ax, cxπ shl cx, 1π add cx, ax {mul by 3}π les di, rgbπ cldπ mov dx, tableReadIndexπ mov al, colorπ out dx, alπ add dx, 2π @L:π in al, dxπ stosbπ loop @Lπ @X:πend;ππ{XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX}ππFunction vgaPresent : Boolean; Assembler;πAsmπ mov ah, $Fπ int $10π mov oldMode, al { save old Gr mode}π mov ax, $1A00π int $10 { check For VGA}π cmp al, $1Aπ jne @ERR { no VGA Bios}π cmp bl, 7π jb @ERR { is VGA or better?}π cmp bl, $FFπ jnz @OKπ @ERR:π xor al, alπ jmp @EXITπ @OK:π mov al, 1π @EXIT:πend;ππProcedure Graphbegin;πVarπ p : Array [0..255] of tRGB;π i, j,π k, l : Byte;πbeginπ Asmπ mov ax, $0013π int $10π end; {set BIOS mode}ππ l := 0;π For i := 0 to 5 doπ For j := 0 to 5 doπ For k := 0 to 5 doπ With p[l] doπ beginπ r := (i * 63) div 5;π g := (j * 63) div 5;π b := (k * 63) div 5;π inc(l);π end;ππ For i := 216 to 255 doπ With p[i] doπ beginπ l := ((i - 216) * 63) div 39;π r := l;π g := l;π b := l;π end;ππ setpalette(0, 256, p);π color := 0;ππ Asmπ mov dx, seqPortπ mov ax, $0604π out dx, ax { disable chain 4}π mov ax, $0100π out dx, ax { synchronous reset asserted}π dec dxπ dec dxπ mov al, $E3π out dx, al { misc output port at $3C2}π { use 25mHz dot clock, 480 lines}π inc dxπ inc dxπ mov ax, $0300π out dx, ax { restart sequencer}π mov dx, CrtcPortπ mov al, $11π out dx, al { select cr11}π inc dxπ in al, dxπ and al, $7Fπ out dx, alπ dec dx { remove Write protect from cr0-cr7}π mov si, offset CrtcRegTableπ mov cx, CrtcRegLenπ repz outsw { set Crtc data}π mov ax, vxBytesπ shr ax, 1 { Words per scan line}π mov ah, alπ mov al, $13π out dx, ax { set CrtC offset reg}π end;ππ clearGraph;πend;ππProcedure Graphend; Far;πbeginπ ExitProc := exitSave;π Asmπ mov al, oldModeπ mov ah, 0π int $10π end;πend;ππbeginπ CrtcPort := memw[$40 : $63];π input1Port := CrtcPort + 6;π if vgaPresent thenπ beginπ ExitSave := exitProc;π ExitProc := @Graphend;π Graphbegin;π endπ elseπ beginπ Writeln(^G + 'VGA required.');π halt(1);π end;πend.π 30 10-28-9311:39ALL BAS VAN GALLEN Another STARS SWAG9311 29 ╓ {===========================================================================π BBS: Canada Remote SystemsπDate: 10-17-93 (23:26)πFrom: BAS VAN GAALENπSubj: Stars?ππ{$N+}ππprogram _Rotation;ππusesπ crt,dos;ππconstπ NofPoints = 75;π Speed = 5;π Xc : real = 0;π Yc : real = 0;π Zc : real = 150;π SinTab : array[0..255] of integer = (π 0,2,5,7,10,12,15,17,20,22,24,27,29,31,34,36,38,41,43,45,47,49,52,54,π 56,58,60,62,64,66,67,69,71,73,74,76,78,79,81,82,83,85,86,87,88,90,91,π 92,93,93,94,95,96,97,97,98,98,99,99,99,100,100,100,100,100,100,100,π 100,99,99,99,98,98,97,97,96,95,95,94,93,92,91,90,89,88,87,85,84,83,π 81,80,78,77,75,73,72,70,68,66,65,63,61,59,57,55,53,51,48,46,44,42,40,π 37,35,33,30,28,26,23,21,18,16,14,11,9,6,4,1,-1,-4,-6,-9,-11,-14,-16,π -18,-21,-23,-26,-28,-30,-33,-35,-37,-40,-42,-44,-46,-48,-51,-53,-55,π -57,-59,-61,-63,-65,-66,-68,-70,-72,-73,-75,-77,-78,-80,-81,-83,-84,π -85,-87,-88,-89,-90,-91,-92,-93,-94,-95,-95,-96,-97,-97,-98,-98,-99,π -99,-99,-100,-100,-100,-100,-100,-100,-100,-100,-99,-99,-99,-98,-98,π -97,-97,-96,-95,-94,-93,-93,-92,-91,-90,-88,-87,-86,-85,-83,-82,-81,π -79,-78,-76,-74,-73,-71,-69,-67,-66,-64,-62,-60,-58,-56,-54,-52,-49,π -47,-45,-43,-41,-38,-36,-34,-31,-29,-27,-24,-22,-20,-17,-15,-12,-10,π -7,-5,-2,0);ππtypeπ PointRec = recordπ X,Y,Z : integer;π end;π PointPos = array[0..NofPoints] of PointRec;ππvarπ Point : PointPos;ππ{----------------------------------------------------------------------------}ππprocedure SetGraphics(Mode : byte); assembler;πasm mov AH,0; mov AL,Mode; int 10h; end;ππ{----------------------------------------------------------------------------}ππprocedure Init;ππvarπ I : byte;ππbeginπ randomize;π for I := 0 to NofPoints do beginπ Point[I].X := random(250)-125;π Point[I].Y := random(250)-125;π Point[I].Z := random(250)-125;π end;πend;ππ{----------------------------------------------------------------------------}ππprocedure DoRotation;ππconstπ Xstep = 1;π Ystep = 1;π Zstep = -2;ππvarπ Xp,Yp : array[0..NofPoints] of word;π X,Y,Z,X1,Y1,Z1 : real;π PhiX,PhiY,PhiZ : byte;π I,Color : byte;ππfunction Sinus(Idx : byte) : real;ππbeginπ Sinus := SinTab[Idx]/100;πend;ππfunction Cosinus(Idx : byte) : real;ππbeginπ Cosinus := SinTab[(Idx+192) mod 255]/100;πend;ππbeginπ PhiX := 0; PhiY := 0; PhiZ := 0;π repeatπ while (port[$3da] and 8) <> 8 do;π while (port[$3da] and 8) = 8 do;π for I := 0 to NofPoints do beginππ if (Xp[I]+160 < 320) and (Yp[I]+100 < 200) thenπ mem[$a000:(Yp[I]+100)*320+Xp[I]+160] := 0;ππ X1 := Cosinus(PhiY)*Point[I].X-Sinus(PhiY)*Point[I].Z;π Z1 := Sinus(PhiY)*Point[I].X+Cosinus(PhiY)*Point[I].Z;π X := Cosinus(PhiZ)*X1+Sinus(PhiZ)*Point[I].Y;π Y1 := Cosinus(PhiZ)*Point[I].Y-Sinus(PhiZ)*X1;π Z := Cosinus(PhiX)*Z1-Sinus(PhiX)*Y1;π Y := Sinus(PhiX)*Z1+Cosinus(PhiX)*Y1;ππ Xp[I] := round((Xc*Z-X*Zc)/(Z-Zc));π Yp[I] := round((Yc*Z-Y*Zc)/(Z-Zc));π if (Xp[I]+160 < 320) and (Yp[I]+100 < 200) then beginπ Color := 31+round(Z/7);π if Color > 31 then Color := 31π else if Color < 16 then Color := 16;π mem[$a000:(Yp[I]+100)*320+Xp[I]+160] := Color;π end;ππ inc(Point[I].Z,Speed); if Point[I].Z > 125 then Point[I].Z := -125;π end;π inc(PhiX,Xstep);π inc(PhiY,Ystep);π inc(PhiZ,Zstep);π until keypressed;πend;ππ{----------------------------------------------------------------------------}ππbeginπ SetGraphics($13);π Init;π DoRotation;π textmode(lastmode);πend.ππ 31 11-02-9305:31ALL DAVE FOSTER Display PIC Files SWAG9311 27 ╓ {πDave Fosterππ> Could anyone please post any routines or help on howπ> to read an image into TURBO 6. I can save the imageπ> in any format, but i need code to be able to displayπ> it on the screen. Source code would be an advantage!π>πI wrote this Program For a friend to read a image into his Program, andπand I would be happy For any help on how to improve it.π}ππProgram Read_Image; { SRC-CODE.PAS ver 1.00 }π{-----------------------------------------------------------------------------π Program reads in a binary data File, and displays the image on the screen byπ using "PutPixel" Procedure in the Graph Unit. The image can be displayed inπ color, or in grey-scale by using the subroutine "Set64Gray" below.π This is a quick and dirty method to display the image using "PutPixel",π and I hope someone will be able to show us how to use the "PutImage" toπ display the image quicker.π-----------------------------------------------------------------------------}ππUsesπ Dos, Crt, Graph;ππTypeπ ByteArray = Array [0..175] of Byte;ππVarπ Gd, Gm,π m, n : Integer;π buffer : ByteArray;π f : File;ππ{π> Does anyone know how can I get a Graphic mode in VGA in which Iπ> could use 64 gray level (at least 32)? Could I keep on using theπ> Graphical Procedures in Unit Graph then?ππ The fragment below will initialize the first 64 VGA color values toπ gray scale. These colors are valid For any VGA mode (including Text),π but in most Graphics modes/devices the Borland Graph Unit limits youπ to using only 16 colors.π}ππProcedure Set64Gray;π{ Sets up 64 shades of gray where 0 = black, 63 = full white }πTypeπ CRec = Recordπ R, G, B: Byte;π end;πVarπ Regs : Registers;π I : Integer;π G64 : Array [0..63] of CRec;πbeginπ { Initialize the block of color values }π For I := 0 to 63 doπ With G64[I] doπ beginπ R := I;π G := I; { Color is gray when RGB values are equal }π B := I;π end;ππ Regs.ax := $1012; { Dos Function to update block of colors }π Regs.bx := 0; { First color to change }π Regs.cx := 64; { Number of colors to change }π Regs.es := seg(G64); { Address of block of color values }π Regs.dx := ofs(G64);π intr($10, Regs);πend;ππbeginπ Gd := detect;π initGraph(Gd, Gm, 'e:\bp\bgi');ππ { Open the image File which is 250 lines, and 175 pixels per line.π Each pixel is 1 Byte, and no header data, or Record delimiters.π File is 43,750 Bytes (250 x 175) in size. Have look at the inputπ File using binary File viewer. }ππ assign(f, 'DOMINO.DAT');π reset(f, 175);ππ { if you enable this, you will be able to see the image in grey-scale,π but I am not sure if it is quite right. Currently it seems to displayπ only few grey-scale levels instead of the full 64 levels.ππ }Set64Gray;ππ { Method used to read the File line at a time, and Write the pixelπ values to the screen. This is bit slow, and it would be lot fasterπ by using "PutImage" but I do not know the method For that. }ππ n := 1;π While not eof(f) doπ beginπ BlockRead(f, buffer, 1);π For m := 1 to 175 doπ PutPixel(m, n, buffer[m]);π n := n + 1;π end;ππ close(f);π readln;π closeGraph;πend.ππ{πThe image File "DOMINO.DAT" used in the Program "SRC-CODE.PAS".πImage File is 250 x 175 pixels (43,750 Bytes).π}ππ 32 11-02-9306:11ALL KEVIN OTTO Fading SWAG9311 11 ╓ { KEVIN OTTO }ππUnit Fade;ππ{ Change DelayAmt and Steps to change the speed of fading. }ππInterfaceππUsesπ Dos, Crt;ππConstπ Colors = 64;π DelayAmt = 15;π Steps = 24;ππTypeπ PalType = Array [0..Colors - 1] of Recordπ R, G, B : Byte;π end;ππVarπ OrigPal : palType;ππProcedure GetPal(Var OrigPal : PalType);πProcedure FadePal(OrigPal : PalType; FadeOut : Boolean);ππImplementationππProcedure GetPal(Var OrigPal : PalType);πVarπ Reg : Registers;πbeginπ With Reg doπ beginπ AX := $1017;π BX := 0;π CX := colors;π ES := seg(OrigPal);π DX := ofs(OrigPal);π intr ($10, Reg);π end;πend;ππProcedure FadePal(OrigPal : PalType; FadeOut : Boolean);πVarπ Reg : Registers;π WorkPal : PalType;π Fade : Word;π Pct : Real;π I : Word;πbeginπ With Reg doπ For Fade := 0 to Steps doπ beginπ Pct := Fade / Steps;π if FadeOut thenπ Pct := 1 - Pct;π For I := 0 to Colors - 1 doπ With WorkPal[I] doπ beginπ R := round(OrigPal[I].R * Pct);π G := round(OrigPal[I].G * Pct);π B := round(OrigPal[I].B * Pct);π end;π AX := $1012;π BX := 0;π CX := Colors;π ES := seg (WorkPal);π DX := ofs (WorkPal);π intr ($10, Reg);π Delay (DelayAmt);π end;πend;ππend.π 33 11-21-9309:28ALL MICHAEL HOENIE Create Chars in Graphics SWAG9311 78 ╓ π { This program allows you to create characters using the GRAPHICS unitπ supplied otherwise with the SWAG routines. If you have any questionsπ on these routines, please let me know.ππ MICHAEL HOENIE - Intelec Pascal Moderator. }ππ program charedit;ππ uses dos, crt;ππ const numnewchars=1;ππ typeπ string80=string[80];ππ var { all variables inside of the game }π char_map:array[1..16] of string[8];π xpos,ypos,x,y,z:integer;π out,incom:string[255];π charout:char;π outfile:text;π char:array[1..16] of byte;ππ procedure loadchar;π typeπ bytearray=array[0..15] of byte;π chararray=recordπ charnum:byte;π chardata:bytearray;π end;π varπ regs:registers;π newchars:chararray;π beginπ with regs doπ beginπ ah:=$11; { video sub-Function $11 }π al:=$0; { Load Chars to table $0 }π bh:=$10; { number of Bytes per Char $10 }π bl:=$0; { Character table to edit }π cx:=$1; { number of Chars we're definig $1}π dx:=176;π for x:=0 to 15 do newchars.chardata[x]:=char[x+1];π es:=seg(newchars.chardata);π bp:=ofs(newchars.chardata);π intr($10,regs);π end;π end;ππ Procedure FastWrite(Col,Row,Attrib:Byte; Str:string80);π beginπ inlineπ ($1E/$1E/$8A/$86/row/$B3/$50/$F6/$E3/$2B/$DB/$8A/$9E/col/π $03/$C3/$03/$C0/$8B/$F8/$be/$00/$00/$8A/$BE/attrib/π $8a/$8e/str/$22/$c9/$74/$3e/$2b/$c0/$8E/$D8/$A0/$49/$04/π $1F/$2C/$07/$74/$22/$BA/$00/$B8/$8E/$DA/$BA/$DA/$03/$46/π $8a/$9A/str/$EC/$A8/$01/$75/$FB/$FA/$EC/$A8/$01/$74/$FB/π $89/$1D/$47/$47/$E2/$Ea/$2A/$C0/$74/$10/$BA/$00/$B0/π $8E/$DA/$46/$8a/$9A/str/$89/$1D/$47/$47/$E2/$F5/$1F);π end;ππ procedure initalize;ππ beginπ for x:=1 to 16 do char[x]:=0;π xpos:=1;π ypos:=1;π for x:=1 to 16 do char_map[x]:=' '; { clear it out }π end;ππ procedure display_screen;π beginπ loadchar;π fastwrite(1,1,$1F,' CHAREDIT - By Michael S. Hoenie ');π fastwrite(1,2,$7,' 12345678 ┌─────Data');π fastwrite(1,3,$7,' ▄▄▄▄▄▄▄▄▄▄ │');π fastwrite(1,4,$7,' 1 █ █ 000');π fastwrite(1,5,$7,' 2 █ █ 000 Single: ░');π fastwrite(1,6,$7,' 3 █ █ 000');π fastwrite(1,7,$7,' 4 █ █ 000 Multiple:');π fastwrite(1,8,$7,' 5 █ █ 000');π fastwrite(1,9,$7,' 6 █ █ 000 ░░░░░░');π fastwrite(1,10,$7,' 7 █ █ 000 ░░░░░░');π fastwrite(1,11,$7,' 8 █ █ 000 ░░░░░░');π fastwrite(1,12,$7,' 9 █ █ 000 U ');π fastwrite(1,13,$7,' 10 █ █ 000 f1=paint spot │ MOVEMENT');π fastwrite(1,14,$7,' 11 █ █ 000 f2=erase spot L──┼──R ');π fastwrite(1,15,$7,' 12 █ █ 000 S=save char │ ');π fastwrite(1,16,$7,' 13 █ █ 000 Q=quit editor D');π fastwrite(1,17,$7,' 14 █ █ 000 C=reset char r=scroll-right');π fastwrite(1,18,$7,' 15 █ █ 000 l=scroll-left');π fastwrite(1,19,$7,' 16 █ █ 000 r=scroll-right');π fastwrite(1,20,$7,' ▀▀▀▀▀▀▀▀▀▀ u=scroll-up');π end;ππ procedure calculate_char;π beginπ for x:=1 to 16 do char[x]:=0;π for x:=1 to 16 doπ beginπ fastwrite(7,x+3,$4F,char_map[x]);π incom:=char_map[x];π y:=0;π if copy(incom,1,1)='█' then y:=y+1;π if copy(incom,2,1)='█' then y:=y+2;π if copy(incom,3,1)='█' then y:=y+4;π if copy(incom,4,1)='█' then y:=y+8;π if copy(incom,5,1)='█' then y:=y+16;π if copy(incom,6,1)='█' then y:=y+32;π if copy(incom,7,1)='█' then y:=y+64;π if copy(incom,8,1)='█' then y:=y+128;π char[x]:=y;π end;π for x:=1 to 16 doπ beginπ str(char[x],incom);π while length(incom)<3 do insert(' ',incom,1);π fastwrite(17,x+3,$4E,incom);π end;π loadchar;π end;ππ procedure do_online;π varπ done:boolean;π int1,int2,int3:integer;π beginπππ done:=false;π int1:=0;π int2:=0;π int3:=0;π while not done doπ beginπ incom:=copy(char_map[ypos],xpos,1);π int1:=int1+1;π if int1>150 then int2:=int2+1;π if int2>4 thenπ beginπ int1:=0;π int3:=int3+1;π if int3>2 then int3:=1;π case int3 ofπ 1:fastwrite(xpos+6,ypos+3,$F,incom);π 2:fastwrite(xpos+6,ypos+3,$F,'');π end;π end;ππ{ this section moved over to be transferred across the network. }ππif keypressed thenπ beginπ charout:=readkey;π out:=charout;π if ord(out[1])=0 thenπ beginπ charout:=readkey;π out:=charout;π fastwrite(60,2,$2F,out);π case out[1] ofπ ';':begin { F1 }π delete(char_map[ypos],xpos,1);π insert('█',char_map[ypos],xpos);π calculate_char;π end;π '<':begin { F2 }π delete(char_map[ypos],xpos,1);π insert(' ',char_map[ypos],xpos);π calculate_char;π end;π 'H':begin { up }π ypos:=ypos-1;π if ypos<1 then ypos:=16;π calculate_char;π end;π 'P':begin { down }π ypos:=ypos+1;π if ypos>16 then ypos:=1;π calculate_char;π end;π 'K':begin { left }π xpos:=xpos-1;π if xpos<1 then xpos:=8;π calculate_char;π end;π 'M':begin { right }π xpos:=xpos+1;π if xpos>8 then xpos:=1;π calculate_char;π end;π end;π end elseπππ begin { regular keys }π case out[1] ofπ 'Q','q':begin { done }π clrscr;π write('Are you SURE you want to quit? (Y/n) ? ');π readln(incom);π case incom[1] ofπ 'Y','y':done:=true;π end;π clrscr;π display_screen;π calculate_char;π end;π 'S','s':begin { save }π assign(outfile,'chardata.txt');π {$i-} reset(outfile) {$i+};π if (ioresult)>=1 then rewrite(outfile);π append(outfile);π writeln(outfile,'Character Char:');π writeln(outfile,'');π writeln(outfile,' 12345678');π for x:=1 to 16 doπ beginπ str(x,out);π while length(out)<6 do insert(' ',out,1);π writeln(outfile,out+char_map[x]);π end;π writeln(outfile,'');π write(outfile,'Chardata:');π for x:=1 to 15 doπ beginπ str(char[x],incom);π write(outfile,incom+',');π end;π str(char[16],incom);π writeln(outfile,incom);π writeln(outfile,'-----------------------------');π close(outfile);π clrscr;π writeln('File was saved under CHARDATA.TXT.');π writeln;π write('Press ENTER to continue ? ');π readln(incom);π clrscr;π display_screen;π calculate_char;π end;π 'U','u':begin { move entire char up }π incom:=char_map[1];π for x:=2 to 16 do char_map[x-1]:=char_map[x];π char_map[16]:=incom;π calculate_char;π end;π 'R','r':begin { move entire char to the right }π for x:=1 to 16 doπ beginπ out:=copy(char_map[x],8,1);π incom:=copy(char_map[x],1,7);π char_map[x]:=out+incom;π end;π calculate_char;π end;π 'L','l':begin { move entire char to the left }π for x:=1 to 16 doπππ beginπ out:=copy(char_map[x],1,1);π incom:=copy(char_map[x],2,7);π char_map[x]:=incom+out;π end;π calculate_char;π end;π 'D','d':begin { move entire char down }π incom:=char_map[16];π for x:=16 downto 2 do char_map[x]:=char_map[x-1];π char_map[1]:=incom;π calculate_char;π end;π 'C','c':begin { reset }π clrscr;π write('Are you SURE you want to clear it? (Y/n) ? ');π readln(incom);π case incom[1] ofπ 'Y','y':initalize;π end;π clrscr;π display_screen;π calculate_char;π end;π end;π end;π end;π end;π end;ππ beginπ textmode(c80);π initalize;π display_screen;π calculate_char;π do_online;π clrscr;π writeln('Thanks for using CHAREDIT!');π end.ππ 34 11-02-9305:54ALL NICK ONOUFRIOU Quick PutImage SWAG9311 22 ╓ {πNICK ONOUFRIOUππI'm writing a small game that requires a transparent putimage Function. Iπnormally use the BGI, but in this Case I need a little bit more speed. Thisπpartial Program shows what I have already. What I want to know is there isπsimple method of masking color 0 so it won't be displayed.π}πProgram PutMan;ππUsesπ Dos, Crt;ππConstπ(* Turbo Pascal, Width= 11 Height= 23 Colors= 256 *)ππ Man : Array [1..259] of Byte = (π $0A,$00,$16,$00,$00,$00,$00,$00,$00,$00,$00,$00,π $00,$00,$00,$00,$00,$00,$00,$02,$02,$02,$00,$00,π $00,$00,$00,$00,$00,$02,$02,$02,$02,$02,$00,$00,π $00,$00,$00,$02,$2C,$2C,$2C,$2C,$2C,$02,$00,$00,π $00,$00,$2C,$10,$10,$2C,$10,$10,$2C,$00,$00,$00,π $00,$2C,$2C,$2C,$2C,$2C,$2C,$2C,$00,$00,$00,$00,π $00,$2C,$0C,$0C,$0C,$2C,$00,$00,$00,$00,$00,$00,π $00,$2C,$2C,$2C,$00,$00,$00,$00,$00,$00,$00,$00,π $00,$0F,$00,$00,$00,$00,$00,$00,$0F,$00,$00,$0F,π $0F,$0F,$00,$00,$00,$00,$00,$0F,$00,$0D,$0D,$0D,π $0D,$0D,$00,$00,$00,$00,$0F,$0D,$0D,$0D,$0D,$0D,π $0D,$0D,$00,$00,$00,$0F,$1F,$1F,$1F,$1F,$1F,$1F,π $1F,$0F,$00,$00,$00,$1F,$1F,$1F,$1F,$1F,$1F,$1F,π $0F,$00,$00,$00,$00,$1F,$1F,$1F,$1F,$1F,$00,$0F,π $00,$00,$00,$00,$00,$0D,$0D,$0D,$00,$00,$0F,$00,π $00,$00,$00,$0D,$0D,$0D,$0D,$0D,$00,$00,$00,$00,π $00,$00,$0D,$0D,$0D,$0D,$0D,$00,$00,$00,$00,$00,π $00,$0D,$0D,$00,$0D,$0D,$00,$00,$00,$00,$00,$00,π $0D,$0D,$00,$0D,$0D,$00,$00,$00,$00,$00,$00,$07,π $07,$00,$07,$07,$00,$00,$00,$00,$00,$00,$07,$07,π $00,$07,$07,$00,$00,$00,$00,$00,$00,$00,$00,$00,π $00,$00,$00,$00,$00,$00,$00);ππTypeπ _screenRec = Array [0..199, 0..319] of Byte;ππVarπ _mcgaScreen : _screenRec Absolute $A000:0000;πππProcedure SetMode(mode : Integer);πVarπ regs : Registers;πbeginπ regs.ah := 0;π regs.al := mode;π intr($10, regs);πend;ππProcedure ClearPage(color : Integer);πbeginπ FillChar(_mcgaScreen, 64000, color);πend;ππProcedure PutImg(x, y : Integer; Var Img);πTypeπ AList = Array[1..$FFFF] of Byte;πVarπ APtr : ^AList;π J, Width,π Height,π Counter : Word;πbeginπ Aptr := @Img;π Width := (Aptr^[2] SHL 8) + Aptr^[1] + 1;π Height := (Aptr^[4] SHL 8) + Aptr^[3] + 1;π Counter := 5;π For j := y to (y + height - 1) doπ beginπ Move(Aptr^[Counter], _mcgaScreen[j, x], Width);π Inc(Counter, Width);π end;πend;ππbeginπ SetMode(19);π ClearPage(Blue);π PutImg(150, 80, Ptr(seg(man), ofs(man))^);π readln;π SetMode(3);πend.π 35 11-02-9305:30ALL NORMAN YEN Display PCX Files SWAG9311 26 ╓ {π> I heard something in this echo about someone having Pascal source to viewπ> .PCX Files and I would appreciate if they would re-post the source if it'sπ> not too long or tell me where I can get it. I am also looking For someπ> good COMM routines For Pascal, anyone have any or no where I can get some?ππThe routine I have will only work With 320x200x256c images.ππ For all those Pascal Programmers who just want something simpleπ to display a 320x200x256 colour PCX File on the screen here it is.π This was a direct translation from the C source code of PCXVIEWπ written by Lee Hamel (Patch), Avalanche coder. I removed theπ Inline assembly code so that you beginners can see what was goingπ on behind those routines.ππNorman Yen - Infinite Dreams BBS - August 11, 1993π}ππTypeπ pcxheader_rec = Recordπ manufacturer : Byte;π version : Byte;π encoding : Byte;π bits_per_pixel : Byte;π xmin, ymin : Word;π xmax, ymax : Word;π hres, vres : Word;π palette : Array [0..47] of Byte;π reserved : Byte;π colour_planes : Byte;π Bytes_per_line : Word;π palette_Type : Word;π filler : Array [0..57] of Byte;π end;ππVarπ header : pcxheader_rec;π width,π depth : Word;π Bytes : Word;π palette : Array [0..767] of Byte;π f : File;π c : Byte;ππProcedure Read_PCX_Line(vidoffset : Word);πVarπ c, run : Byte;π n : Integer;π w : Word;πbeginπ n := 0;π While (n < Bytes) doπ beginπ blockread (f, c, 1);π { if it's a run of Bytes field }π if ((c and 192) = 192) thenπ beginπ { and off the high bits }π run := c and 63;π { get the run Byte }π blockread (f, c, 1);π n := n + run;π For w := 0 to run - 1 doπ beginπ mem[$a000 : vidoffset] := c;π inc(vidoffset);π end;π endπ elseπ beginπ n := n + 1;π mem[$a000 : vidoffset] := c;π inc(vidoffset);π end;π end;πend;ππProcedure Unpack_PCX_File;πVarπ i : Integer;πbeginπ For i := 0 to 767 doπ palette[i] := palette[i] shr 2;π Asmπ mov ax, 13hπ int 10hπ mov ax, 1012hπ xor bx, bxπ mov cx, 256π mov dx, offset paletteπ int 10hπ end;π For i := 0 to depth - 1 doπ Read_PCX_Line(i * 320);π Asmπ xor ax, axπ int 16hπ mov ax, 03hπ int 10hπ end;πend;ππbeginπ if (paramcount > 0) thenπ beginπ assign(f, paramstr(1));π reset(f, 1);π blockread (f, header, sizeof(header));π if (header.manufacturer = 10) and (header.version = 5) andπ (header.bits_per_pixel = 8) and (header.colour_planes = 1) thenπ beginπ seek(f, Filesize(f) - 769);π blockread(f, c, 1);π if (c = 12) thenπ beginπ blockread(f, palette, 768);π seek(f, 128);π width := header.xmax - header.xmin + 1;π depth := header.ymax - header.ymin + 1;π Bytes := header.Bytes_per_line;π Unpack_PCX_File;π endπ elseπ Writeln('Error reading palette.');π endπ elseπ Writeln('Not a 256 colour PCX File.');π close(f);π endπ elseπ Writeln('No File name specified.');πend.π 36 10-28-9311:35ALL NORMAN YEN View PCX File SWAG9311 28 ╓ {===========================================================================πDate: 08-23-93 (08:26)πFrom: NORMAN YENπSubj: RE: .PCX AND COMM ROUTINEπ---------------------------------------------------------------------------ππ MB> I heard something in this echo about someone having Pascal source toπ MB> view .PCXπ MB> files and I would appreciate if they would re-post the source if it'sπ MB> not tooπ MB> long or tell me where I can get it. I am also looking for some goodπ MB> COMM routines for Pascal, anyone have any or no where I can get some?ππ The routine I have will only work with 320x200x256c images.πHope it helps!ππNormanππ{π For all those Pascal programmers who just want something simpleπ to display a 320x200x256 colour PCX file on the screen here it is.π This was a direct translation from the C source code of PCXVIEWπ written by Lee Hamel (Patch), Avalanche coder. I removed theπ inline assembly code so that you beginners can see what was goingπ on behind those routines.ππ Norman Yenπ Infinite Dreams BBSπ August 11, 1993π}ππtype pcxheader_rec=recordπ manufacturer: byte;π version: byte;π encoding: byte;π bits_per_pixel: byte;π xmin, ymin: word;π xmax, ymax: word;π hres: word;π vres: word;π palette: array [0..47] of byte;π reserved: byte;π colour_planes: byte;π bytes_per_line: word;π palette_type: word;π filler: array [0..57] of byte;π end;ππvar header: pcxheader_rec;π width, depth: word;π bytes: word;π palette: array [0..767] of byte;π f: file;π c: byte;ππprocedure Read_PCX_Line(vidoffset: word);πvar c, run: byte;π n: integer;π w: word;πbeginπ n:=0;π while (n < bytes) doπ beginπ blockread (f, c, 1);ππ { if it's a run of bytes field }π if ((c and 192)=192) thenπ beginππ { and off the high bits }π run:=c and 63;ππ { get the run byte }π blockread (f, c, 1);π n:=n+run;π for w:=0 to run-1 doπ beginπ mem [$a000:vidoffset]:=c;π inc (vidoffset);π end;π end elseπ beginπ n:=n+1;π mem [$a000:vidoffset]:=c;π inc (vidoffset);π end;π end;πend;ππprocedure Unpack_PCX_File;πvar i: integer;πbeginπ for i:=0 to 767 doπ palette [i]:=palette [i] shr 2;π asmπ mov ax,13hπ int 10hπ mov ax,1012hπ xor bx,bxπ mov cx,256π mov dx,offset paletteπ int 10hπ end;π for i:=0 to depth-1 doπ Read_PCX_Line (i*320);π asmπ xor ax,axπ int 16hπ mov ax,03hπ int 10hπ end;πend;ππbeginπ if (paramcount > 0) thenπ beginπ assign (f, paramstr (1));π reset (f,1);π blockread (f, header, sizeof (header));π if (header.manufacturer=10) and (header.version=5) andπ (header.bits_per_pixel=8) and (header.colour_planes=1) thenπ beginπ seek (f, filesize (f)-769);π blockread (f, c, 1);π if (c=12) thenπ beginπ blockread (f, palette, 768);π seek (f, 128);π width:=header.xmax-header.xmin+1;π depth:=header.ymax-header.ymin+1;π bytes:=header.bytes_per_line;π Unpack_PCX_File;π end else writeln ('Error reading palette.');π end else writeln ('Not a 256 colour PCX file.');π close (f);π end else writeln ('No file name specified.');πend.ππ 37 11-02-9305:49ALL RANDY PARKER Writing to Graphic Pages SWAG9311 9 ╓ {πRANDY PARKERππ I've been playing With using the Absolute address $A000:0000 to do directπvideo Writes in Graphics mode and was wondering if someone could tell me howπto get colors. I use an Array of [1..NumOfBits]. NumOfBits being the numberπof bits the current Graphic page Uses when it stores it's information.ππThe following is an example of what I mean:π}ππProgram UseFastGraf;πUsesπ Graph;ππTypeπ View = Array [1..19200] of Word;ππVarπ I,π GraphDriver,π GraphMode : Integer;π View1 : View Absolute $A000:0000;π View2 : View;ππbeginπ GraphDriver := Detect;π InitGraph(GraphDriver, GraphMode, 'e:\bp\bgi');π For I := 1 to 1000 Doπ beginπ SetColor(Random(GetMaxColor));π Line(Random(GetMaxX), Random(GetMaxY), Random(GetMaxX), GetMaxY);π end;π View2 := View1;π SetColor(15);π OutTextXY(100, 100, 'Press Enter To Continue : ');π Readln;π ClearDevice;π OutTextXY(100, 100, 'Press Enter To See The Previous Screen');π Readln;π View1 := View2;π Readln;πend.ππ 38 11-02-9305:56ALL SEAN PALMER Another QUICK PutImage SWAG9311 18 ╓ (*πSEAN PALMERππ> there is simple method of masking color 0 so it won't be displayed.π> An assembly language routine based around this:ππProcedure PutImg(x, y : Integer; Var Img);πTypeπ AList = Array[1..$FFFF] of Byte; {1-based Arrays are slower than 0-based}πVarπ APtr : ^AList; {I found a very fast way to do this: With}π j, i,π Width,π Height,π Counter : Word;πbeginπ Aptr := @Img;π Width := (Aptr^[2] SHL 8) + Aptr^[1] + 1; {these +1's that 1-based Arrays }π Height := (Aptr^[4] SHL 8) + Aptr^[3] + 1; { require make For slower code}π Counter := 5;π For j := y to (y + height - 1) doπ begin {try pre-calculating the offset instead}π For i := x to (x + width - 1) doπ beginπ Case Aptr^[Counter] of {CASE is probably not the way to do this}π 0:; { do nothing }π else _mcgaScreen[j, i] := Aptr^[Counter]; { plot it }π end;π Inc(Counter);π end;π end;πend;ππok, here's my try:π*)ππTypeπ pWord = ^Word;ππProcedure putImg(x, y : Integer; Var image);πVarπ anImg : Recordπ img : Array [0..$FFF7] of Byte;π end Absolute image;ππ aScrn : Recordπ scrn : Array [0..$FFF7] of Byte;π end Absolute $A000 : 0000;ππ width,π height,π counter,π offs, src : Word;ππbeginπ width := pWord(@anImg[0])^;π height := pWord(@anImg[2])^;π offs := y * 320 + x;π src := 4; {skip width, height}π With aScrn, anImg doπ Repeatπ counter := width;π Repeatπ if img[src] <> 0 thenπ scrn[offs] := img[src];π inc(src);π inc(offs);π dec(counter);π Until counter = 0;π inc(offs, 320 - width);π dec(height);π Until height = 0;πend;ππ{πThose Arrays-pretending-to-be-Records above so they'll work With the Withπstatement should end up making BP keep the address in Registers, making itπfaster. In any Case it won't be slower than yours. I'd appreciate youπtiming them and letting me know the results. Actually, let me know if itπeven compiles and works... 8)ππBut Really, man, if you're writing Graphics routines you Really have toπgo For assembly. Pascal don't cut it. (c doesn't either...)π}π 39 11-02-9317:44ALL SEAN PALMER Bresenham Line SWAG9311 12 ╓ {πFrom: SEAN PALMERπSubj: Bresenham's LineππYou need a plot(x,y) procedure and a global color variable to use these asπposted. }πππ{bresenham's line}πprocedure line(x,y,x2,y2:integer);var d,dx,dy,ai,bi,xi,yi:integer;beginπ if(x<x2)then begin xi:=1;dx:=x2-x;end else begin xi:=-1;dx:=x-x2;end;π if(y<y2)then begin yi:=1;dy:=y2-y;end else begin yi:=-1;dy:=y-y2;end;π plot(x,y);π if dx>dy then begin ai:=(dy-dx)*2;bi:=dy*2; d:=bi-dx;π repeatπ if(d>=0)then begin inc(y,yi);inc(d,ai);end else inc(d,bi);π inc(x,xi);plot(x,y);π until(x=x2);π endπ else begin ai:=(dx-dy)*2;bi:=dx*2; d:=bi-dy;π repeatπ if(d>=0)then begin inc(x,xi);inc(d,ai);end else inc(d,bi);π inc(y,yi);plot(x,y);π until(y=y2);π end;π end;πππ{filled ellipse}πprocedure disk(xc,yc,a,b:integer);π var x,y:integer; aa,aa2,bb,bb2,d,dx,dy:longint; beginπ x:=0;y:=b;π aa:=longint(a)*a; aa2:=2*aa;π bb:=longint(b)*b; bb2:=2*bb;π d:=bb-aa*b+aa div 4;π dx:=0;dy:=aa2*b;π vLin(xc,yc-y,yc+y);π while(dx<dy)do beginπ if(d>0)then begin dec(y); dec(dy,aa2); dec(d,dy); end;π inc(x); inc(dx,bb2); inc(d,bb+dx);π vLin(xc-x,yc-y,yc+y);vLin(xc+x,yc-y,yc+y);π end;π inc(d,(3*(aa-bb)div 2-(dx+dy))div 2);π while(y>=0)do beginπ if(d<0)then beginπ inc(x); inc(dx,bb2); inc(d,bb+dx);π vLin(xc-x,yc-y,yc+y);vLin(xc+x,yc-y,yc+y);π end;π dec(y); dec(dy,aa2); inc(d,aa-dy);π end;π end;π 40 11-02-9317:24ALL SEAN PALMER Transparent PutImage SWAG9311 15 ╓ {πFrom: SEAN PALMERπSubj: transparent putimageπ}ππProcedure PutImg(x,y : integer;Var Img);πtypeπ AList = array[1..$FFFF] of Byte; {1-based arrays are slower than 0-based}πvarπ APtr : AList; {I found a very fast way to do this: WITH}π j,i,Width,Height,Counter : Word;πbeginπ Aptr:=@Img;π Width:=(Aptr] SHL 8) + Aptr]+1; {these +1's that 1-based arrays }π Height:=(Aptr] SHL 8) + Aptr]+1; { require make for slower code}π Counter:=5;π For j:=y to (y+height-1) do begin {try pre-calculating the offset instead}π for i:=x to (x+width-1) do beginπ case AptrCounter] of {CASE is probably not the way to do this}π 0:; (* do nothing *)π else _mcgaScreen[j,i]:=AptrCounter]; (* plot it *)π end;π Inc(Counter);π end;π end;π end;ππok, here's my try:ππtype pWord=word;ππprocedure putImg(x,y:integer;var image);πvarπ anImg:record img:array[0..$FFF7]of byte; end absolute image;π aScrn:record scrn:array[0..$FFF7]of byte; end absolute $A000:0000;π width,height,counter,offs,src:word;πbeginπ width:=pWord(@anImg[0])π height:=pWord(@anImg[2])π offs:=y*320+x;π src:=4; {skip width, height}π with aScrn,anImg do repeatπ counter:=width;π repeatπ if img[src]<>0 then scrn[offs]:=img[src];π inc(src);π inc(offs);π dec(counter);π until counter=0;π inc(offs,320-width);π dec(height);π until height=0;π end;πππThose arrays-pretending-to-be-records above so they'll work with the WITHπstatement should end up making BP keep the address in registers, making itπfaster. In any case it won't be slower than yours. I'd appreciate youπtiming them and letting me know the results. Actually, let me know if itπeven compiles and works... 8)π 41 11-02-9305:55ALL STEFAN XENOS Loading Images from Disk SWAG9311 27 ╓ {πSTEFAN XENOSππ> I am able to load an image into a buffer and display it with PutImage ect.,π> but I would like to load the image from disk instead of with getimage.ππName: ImageStuff.PasπPurpose: ImageStuff is a unit for storing bitmaps in dynamic variables andπ writing them to disk.πProgger: Stefan XenosππThis unit is public domain.}ππUnit ImageStuff;ππinterfaceππUsesπ Graph;ππTypeπ Image = Recordπ BitMap : Pointer;π Size : Word;π end;ππProcedure Get(X1, Y1, X2, Y2 : Word; Var aImage : Image);πProcedure Put(X, Y : Word; aImage : Image; BitBlt : Word);πProcedure Kill(Var aImage : Image);πProcedure Save(Var F : File; aImage : Image);πProcedure Load(Var F : File; Var aImage : Image);ππimplementationππProcedure Get(X1, Y1, X2, Y2 : Word; Var aImage : Image);π{Clips an image from the screen and store it in a dynamic variable}πBeginπ aImage.bitmap := nil;π aImage.size := ImageSize(X1, Y1, X2, Y2);π GetMem(aImage.BitMap,aImage.Size); {Ask for some memory}π GetImage(X1, Y1, X2, Y2, aImage.BitMap^); {Copy the image}πEnd;ππProcedure Put(X, Y : Word; aImage : Image; BitBlt : Word);πBeginπ PutImage(X, Y, aImage.BitMap^, BitBlt); {Display image}πEnd;ππProcedure Kill(Var aImage : Image);π{Frees up the memory used by an unwanted image}πBeginπ FreeMem (aImage.BitMap, aImage.Size); {Free up memory used by image}π aImage.Size := 0;π aImage.BitMap := Nil;πEnd;ππProcedure Save(Var F : File; aImage : Image);π{Saves an image to disk. File MUST already be opened for write}πBeginπ BlockWrite(F, aImage.Size, 2); {Store the image's size so thatπ it may be correctly loaded later}π BlockWrite(F, aImage.BitMap^, aImage.Size); {Write image itself to disk}πEnd;ππProcedure Load (Var F : File; Var aImage : Image);π{Loads an image off disk and stores it in a dynamic variable}πBeginπ BlockRead(F, aImage.Size, 2); {Find out how big the image is}π GetMem(aImage.BitMap, aImage.Size); {Allocate memory for it}π BlockRead(F, aImage.BitMap^, aImage.Size) {Load the image}πEnd;ππBeginπEnd.ππ{πHere's some source which should help you figure out how to use the unit Iπjust sent.π}ππ{By Stefan Xenos}πProgram ImageTest;ππUsesπ Graph,π ImageStuff;ππVarπ Pic : Image;π LineNum : Byte;π DataFile : File;π GrDriver,π GrMode : Integer;ππConstπ FileName = 'IMAGE.DAT';π MaxLines = 200;ππBeginπ {Initialise}π DetectGraph(GrDriver, GrMode);π InitGraph(GrDriver, GrMode, '');π Randomize;ππ {Draw some lines}π For LineNum := 1 to MaxLines doπ beginπ setColor(random (maxcolors));π line(random(getmaxx), random(getmaxy), random(getmaxx), random(getmaxy));π end;ππ {Copy image from screen}π Get(100, 100, 150, 150, Pic);ππ readLn;ππ {Clear screen}π ClearDevice;ππ {Display image}π Put(100, 100, Pic, NormalPut);ππ readLn;ππ {Clear screen}π ClearDevice;ππ {Save image to disk}π Assign(DataFile, FileName);π Rewrite(DataFile, 1);π Save(DataFile, Pic);π Close(DataFile);ππ {Kill image}π Kill(pic);ππ {Load image from disk}π Assign(DataFile, FileName);π Reset(DataFile, 1);π Load(DataFile, pic);π Close(DataFile);ππ {Display image}π Put(200, 200, Pic, NormalPut);ππ readLn;ππ CloseGraph;π WriteLn(Pic.size);πEnd.π 42 11-02-9304:50ALL STEVE BOUTILIER Simple & QUICK Graphics SWAG9311 8 ╓ { STEVE BOUTILIER }ππUsesπ Dos,π Crt;ππProcedure OpenGraphics; Assembler;πAsmπ Mov Ah, 00hπ Mov Al, 13hπ Int $10πend;ππProcedure CloseGraphics; Assembler;πAsmπ Mov Ah, 00hπ Mov Al, 03hπ Int $10πend;ππProcedure PutXY(X, Y : Byte); Assembler;πAsmπ Mov Ah, 02hπ Mov Dh, Y - 1π Mov Dl, X - 1π Mov Bh, 0π Int $10πend;ππProcedure OutChar(S : Char; Col : Byte); Assembler;πAsmπ Mov Ah, 0Ehπ Mov Al, Sπ Mov Bh, 0π Mov Bl, Colπ Int $10πend;ππProcedure OutString(S : String; Col : Byte);πVarπ I : Integer;π Ch : Char;πbeginπ For I := 1 to Length(s) doπ beginπ Ch := S[I];π OutChar(Ch, Col);π end;πend;ππbeginπ OpenGraphics;π OutString('HELLO WORLD!' + #13#10, 14);π Repeat Until KeyPressed;π CloseGraphics;πend.ππ{πBTW: This code is Public Domain! Do what you want With it! most of youπ probably already have routines that are even better than this.π}ππ 43 11-02-9305:52ALL VINCE LAURENT Scalable HEX Screen SWAG9311 25 ╓ {πVINCE LAURENTππI wrote some code to draw a scalable hex field on the screen. Canπanyone give me a hand in optimizing it? There is a lot of redundantπline drawing and positioning... I would also like to be able to haveπa fexible amount of hexigons showing. For example, if the scale is,πsay 40, show 19 hexs, if it is smaller, show more (like as many thatπcould have fit in the area occupied by 19).ππBTW, this code can be freely used and distributed or completely ignored :-) }ππProgram HexzOnScreen;πUsesπ Graph, Crt;πTypeπ PtArray = Array [1..6, 1..2] of Real;πVarπ s1, s2,π side,π i, j,π Gd, Gm : Integer;π Pts : PtArray;π ErrCode : Integer;π Sqrt3,π sts : Real;ππbeginπ Sqrt3 := Sqrt(3);π Side := 40; { initial hex side length ( min = 8 ) }π sts := Side * Sqrt3;π s1 := 200;π s2 := 60; { starting point For hex field }π InitGraph(Gd, Gm, 'e:\bp\bgi\');π ErrCode := GraphResult;π if not ErrCode = grOk thenπ beginπ Writeln('Error: ', GraphErrorMsg(ErrCode));π Halt(0);π end;π SetColor(LightGray);π Delay(10); { give the screen a chance to toggle to Graph mode }π For j := 1 to 17 DOπ beginπ Pts[1, 1] := s1;π Pts[1, 2] := s2;π Pts[2, 1] := Pts[1, 1] - side;π Pts[2, 2] := Pts[1, 2];π Pts[3, 1] := Pts[1, 1] - side - (side / 2);π Pts[3, 2] := Pts[1, 2] + (sts / 2);π Pts[4, 1] := Pts[1, 1] - side;π Pts[4, 2] := Pts[1, 2] + sts ;π Pts[5, 1] := Pts[1, 1];π Pts[5, 2] := Pts[4, 2];π Pts[6, 1] := Pts[1, 1] + (side / 2);π Pts[6, 2] := Pts[1, 2] + (sts / 2);π For I := 1 to 6 DOπ beginπ if i <> 6 thenπ Line(Round(Pts[i, 1]), Round(Pts[i, 2]),π Round(Pts[i + 1, 1]), Round(Pts[i + 1, 2]))π elseπ Line(Round(Pts[i, 1]), Round(Pts[i, 2]),π Round(Pts[1, 1]), Round(Pts[1, 2]));π end;π Case j OFπ 1..2 :π beginπ s1 := Round(Pts[6, 1] + side);π s2 := Round(Pts[6, 2]);π end;π 3..4 :π beginπ s1 := Round(Pts[5, 1]);π s2 := Round(Pts[5, 2]);π end;π 5..6 :π beginπ s1 := Round(Pts[3, 1]);π s2 := Round(Pts[3, 2]);π end;π 7..8 :π beginπ s1 := Round(Pts[3, 1]);π s2 := Round(Pts[3, 2] - sts);π end;π 9..10 :π beginπ s1 := Round(Pts[1, 1]);π s2 := Round(Pts[1, 2] - sts);π end;π 11 :π beginπ s1 := Round(Pts[6, 1] + side);π s2 := Round(Pts[6, 2] - sts);π end;π 12..13 :π beginπ s1 := Round(Pts[6, 1] + side);π s2 := Round(Pts[6, 2]);π end;π 14 :π beginπ s1 := Round(Pts[5, 1]);π s2 := Round(Pts[5, 2]);π end;π 15 :π beginπ s1 := Round(Pts[3, 1]);π s2 := Round(Pts[3, 2]);π end;π 16 :π beginπ s1 := Round(Pts[3, 1]);π s2 := Round(Pts[3, 2] - sts);π end;π end;π end;π Line(s1, s2, Round(s1 + (side / 2)), Round(s2 - sts / 2));π Readln;π CloseGraph;πend.π 44 11-21-9309:44ALL WILLIAM PLANKE Writing PCX files SWAG9311 94 ╓ {πFrom: WILLIAM PLANKEπSubj: Write PCX example 1/4ππAs I follow this forum, many requests are made for PCX graphicsπfile routines. Those that are looking for Read_PCX info canπfind it on the ZSoft BBS in a wonderful Pascal example: ShowPCX.ππOn the other hand, there is next to zilch out there on how toπWrite_PCX files. I know.... I searched and searched and couldn'tπfind a thing! So with a little brute force and a few ZSoftπC language snippets <groan>, I got this together:π}πππ{ =================== TPv6.0 P C X _ W ======================== }ππ{$R-} {Range checking, turn off when debugged}ππunit PCX_W;ππ{ --------------------- Interface ----------------- }ππinterfaceππtypeπ Str80 = string [80];ππprocedure Write_PCX (Name:Str80);πππ{ ===================== Implementation ============ }ππimplementationππusesπ Graph;πππ{-------------- Write_PCX --------------}ππprocedure Write_PCX (Name:Str80);ππconstπ RED1 = 0;π GREEN1 = 1;π BLUE1 = 2;ππtypeπ ArrayPal = array [0..15, RED1..BLUE1] of byte;ππconstπ MAX_WIDTH = 4000; { arbitrary - maximum width (in bytes) ofπ a PCX image }π INTENSTART = $5;π BLUESTART = $55;π GREENSTART = $A5;π REDSTART = $F5;ππtypeπ Pcx_Header = recordπ {comments from ZSoft ShowPCX pascal example}ππ Manufacturer: byte; { Always 10 for PCX file }ππ Version: byte; { 2 - old PCX - no palette (not usedπ anymore),π 3 - no palette,π 4 - Microsoft Windows - no paletteπ (only in old files, new Windowsπ version uses 3),π 5 - with palette }ππ Encoding: byte; { 1 is PCX, it is possible that we mayπ add additional encoding methods in theπ future }ππ Bits_per_pixel: byte; { Number of bits to represent a pixelπ (per plane) - 1, 2, 4, or 8 }ππ Xmin: integer; { Image window dimensions (inclusive) }π Ymin: integer; { Xmin, Ymin are usually zero (not always)}π Xmax: integer;π Ymax: integer;ππ Hdpi: integer; { Resolution of image (dots per inch) }π Vdpi: integer; { Set to scanner resolution - 300 isπ default }ππ ColorMap: ArrayPal;π { RGB palette data (16 colors or less)π 256 color palette is appended to endπ of file }ππ Reserved: byte; { (used to contain video mode)π now it is ignored - just set to zero }ππ Nplanes: byte; { Number of planes }ππ Bytes_per_line_per_plane: integer; { Number of bytes toπ allocate for a scanlineπ plane. MUST be an an EVENπ number! Do NOT calculateπ from Xmax-Xmin! }ππ PaletteInfo: integer; { 1 = black & white or color image,π 2 = grayscale image - ignored in PB4,π PB4+ palette must also be set toπ shades of gray! }ππ HscreenSize: integer; { added for PC Paintbrush IV Plusπ ver 1.0, }π VscreenSize: integer; { PC Paintbrush IV ver 1.02 (and later)}π { I know it is tempting to use theseπ fields to determine what video modeπ should be used to display the imageπ - but it is NOT recommended since theπ fields will probably just containπ garbage. It is better to have theπ user install for the graphics mode heπ wants to use... }ππ Filler: array [74..127] of byte; { Just set to zeros }π end;ππ Array80 = array [1..80] of byte;π ArrayLnImg = array [1..326] of byte; { 6 extra bytes atπ beginng of line that BGI uses for size info}π Line_Array = array [0..MAX_WIDTH] of byte;π ArrayLnPCX = array [1..4] of Array80;ππvarπ PCXName : File;π Header : Pcx_Header; { PCX file header }π ImgLn : ArrayLnImg;π PCXLn : ArrayLnPCX;π RedLn,π BlueLn,π GreenLn,π IntenLn : Array80;π Img : pointer;πππ{-------------- BuildHeader- -----------}ππprocedure BuildHeader;ππconstπ PALETTEMAP: ArrayPal=π { R G B }π (($00, $00, $00), { black }π ($00, $00, $AA), { blue }π ($00, $AA, $00), { green }π ($00, $AA, $AA), { cyan }π ($AA, $00, $00), { red }π ($AA, $00, $AA), { magenta }π ($AA, $55, $00), { brown }π ($AA, $AA, $AA), { lightgray }π ($55, $55, $55), { darkgray }π ($55, $55, $FF), { lightblue }π ($55, $FF, $55), { lightgreen }π ($55, $FF, $FF), { lightcyan }π ($FF, $55, $55), { lightred }π ($FF, $55, $FF), { lightmagenta }π ($FF, $FF, $55), { yellow }π ($FF, $FF, $FF) );{ white }ππvarπ i : word;ππbeginπ with Header doπ beginπ Manufacturer := 10;π Version := 5;π Encoding := 1;π Bits_per_pixel := 1;π Xmin := 0;π Ymin := 0;π Xmax := 639;π Ymax := 479;π Hdpi := 640;π Vdpi := 480;π ColorMap := PALETTEMAP;π Reserved := 0;π Nplanes := 4; { Red, Green, Blue, Intensity }π Bytes_per_line_per_plane := 80;π PaletteInfo := 1;π HscreenSize := 0;π VscreenSize := 0;π for i := 74 to 127 doπ Filler [i] := 0;π end;πend;πππ{-------------- GetBGIPlane ------------}ππprocedure GetBGIPlane (Start:word; var Plane:Array80);ππvarπ i : word;ππbeginπ for i:= 1 to Header.Bytes_per_line_per_plane doπ Plane [i] := ImgLn [Start +i -1]πend;ππ{-------------- BuildPCXPlane ----------}ππprocedure BuildPCXPlane (Start:word; Plane:Array80);ππvarπ i : word;ππbeginπ for i := 1 to Header.Bytes_per_line_per_plane doπ PCXLn [Start] [i] := Plane [i];πend;πππ{-------------- EncPCXLine -------------}ππprocedure EncPCXLine (PlaneLine : word); { Encode a PCX line }ππvarπ This,π Last,π RunCount : byte;π i,π j : word;πππ {-------------- EncPut -----------------}ππ procedure EncPut (Byt, Cnt :byte);ππ constπ COMPRESS_NUM = $C0; { this is the upper two bits thatπ indicate a count }ππ varπ Holder : byte;ππ beginπ {$I-}π if (Cnt = 1) and (COMPRESS_NUM <> (COMPRESS_NUM and Byt)) thenπ blockwrite (PCXName, Byt,1) { single occurance }π {good place for file error handler!}π elseπ beginπ Holder := (COMPRESS_NUM or Cnt);π blockwrite (PCXName, Holder, 1); { number of times theπ following colorπ occurs }π blockwrite (PCXName, Byt, 1);π end;π {$I+}π end;πππbeginπ i := 1; { used in PCXLn }π RunCount := 1;π Last := PCXLn [PlaneLine][i];π for j := 1 to Header.Bytes_per_line_per_plane -1 doπ beginπ inc (i);π This := PCXLn [PlaneLine][i];π if This = Last thenπ beginπ inc (RunCount);π if RunCount = 63 then { reached PCX run lengthπ limited max yet? }π beginπ EncPut (Last, RunCount);π RunCount := 0;π end;π endπ elseπ beginπ if RunCount >= 1 thenπ Encput (Last, RunCount);π Last := This;π RunCount := 1;π end;π end;π if RunCount >= 1 then { any left over ? }π Encput (Last, RunCount);πend;ππ { - - -W-R-I-T-E-_-P-C-X- - - - - - - - }ππconstπ XMAX = 639;π YMAX = 479;ππvarπ i, j, Size : word;ππbeginπ BuildHeader;π assign (PCXName,Name);π{$I-}π rewrite (PCXName,1);π blockwrite (PCXName,Header,sizeof (Header));π {good place for file error handler!}π{$I+}π setviewport (0,0,XMAX,YMAX, ClipOn);π Size := imagesize (0,0,XMAX,0); { size of a single row }π getmem (Img,Size);ππ for i := 0 to YMAX doπ beginπ getimage (0,i,XMAX,i,Img^); { Grab 1 line from theπ screen store in Imgπ buffer }π move (Img^,ImgLn,Size {326});πππ GetBGIPlane (INTENSTART, IntenLn);π GetBGIPlane (BLUESTART, BlueLn );π GetBGIPlane (GREENSTART, GreenLn);π GetBGIPlane (REDSTART, RedLn );π BuildPCXPlane (1, RedLn );π BuildPCXPlane (2, GreenLn);π BuildPCXPlane (3, BlueLn );π BuildPCXPlane (4, IntenLn); { 320 bytes/lineπ uncompressed }π for j := 1 to Header.NPlanes doππ EncPCXLine (j);π end;π freemem (Img,Size); (* Release the memory *)π{$I-}π close (PCXName); (* Save the Image *)π{$I+}πend;ππend {PCX.TPU} .πππ{ -----------------------Test Program -------------------------- }ππprogram WritePCX;ππusesπ Graph, PCX_W;ππ{-------------- DrawHorizBars ----------}ππprocedure DrawHorizBars;ππvarπ i, Color : word;ππbeginπ cleardevice;π Color := 15;π for i := 0 to 15 doπ beginπ setfillstyle (solidfill,Color);π bar (0,i*30,639,i*30+30); { 16*30 = 480 }π dec (Color);π end;πend;ππ{-------------- Main -------------------}ππvarπ NameW : Str80;π Gd,π Gm : integer;ππbeginπ writeln;π if (ParamCount = 0) then { no DOS command lineπ parameters }π beginπ write ('Enter name of PCX picture file to write: ');π readln (NameW);π writeln;π endπ elseπ beginπ NameW := paramstr (1); { get filename from DOSπ command line }π end;ππ if (Pos ('.', NameW) = 0) then { make sure the filenameπ has PCX extension }π NameW := Concat (NameW, '.pcx');ππ Gd:=VGA;π Gm:=VGAhi; {640x480, 16 colors}π initgraph (Gd,Gm,'..\bgi'); { path to your EGAVGA.BGI }ππ DrawHorizBars;ππ readln;π Write_PCX (NameW); { PCX_W.TPU }π closegraph; { Close graphics }π textmode (co80); { back to text mode }πend. { Write_PCX }π
